Copy a range to different sheets depending on first cell contents

**WaveOfMutilation** · 02-24-2010, 11:47 AM

Hi all,

Mostly thanks to romperstomper, I have been using the below code to pull a range from a number of files and copy them all in to a new sheet. However, I now need to copy the range in to one of a number of sheets (3 at the moment) depending on the contents of the first cell.

Pretty sure I should be able to do this myself eventually, but I'm runnin short on time and so I could use your expert help again.

Many thanks

Matt


Sub DoProcessing()
    ProcessAllWorkbooksInFolder "K:\Cndadm\Pulse Survey Test", "Training*.xls", False
End Sub
Sub ProcessAllWorkbooksInFolder(strParentFolder As String, Optional strFilter As String = "*.xls", Optional blnDoSubFolders As Boolean = False)
        
    Dim FS As FileSearch
    Dim lngCounter As Long
    Dim wbk As Workbook
    Dim wksOut As Worksheet
    Dim rngOut As Range
    
    Application.ScreenUpdating = False
        
    Set wksOut = ActiveSheet
    
    Set rngOut = wksOut.Range("C4")
    
    Set FS = Application.FileSearch
    With FS
        .NewSearch
        .LookIn = strParentFolder
        .SearchSubFolders = blnDoSubFolders
        ' adjust as required
        .Filename = strFilter
        .MatchTextExactly = True
        .FileType = msoFileTypeExcelWorkbooks
        .Execute
              
        For lngCounter = 1 To .FoundFiles.Count
            Set wbk = Workbooks.Open(.FoundFiles(lngCounter))
            ProcessWorkbook wbk, rngOut
            wbk.Close False
            Set rngOut = wksOut.Cells(1, Columns.Count).End(xlToLeft).Offset(, 1)
        Next lngCounter
        
        Set wbk = Nothing
    End With
    Set FS = Nothing
    Application.ScreenUpdating = True
End Sub

Sub ProcessWorkbook(wbk As Workbook, rngDest As Range)
    wbk.Sheets(2).Range("A1:A30").Copy
    rngDest.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
       :=False, Transpose:=False
End Sub

**pike** · 02-25-2010, 03:18 AM

maybe if its not to late

Sub ProcessWorkbook(wbk As Workbook, rngDest As Range)
    if Sheets(2).Range("A1")= 100
    wbk.Sheets(2).Range("A1:A30").Copy
    rngDest.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
       :=False, Transpose:=False
  end if
End Sub

**WaveOfMutilation** · 02-25-2010, 05:38 AM

Hi pike,

Thanks for that, it gets me on my way. Would give me a sheet with all the ranges where the cell contents is "A". Next question, how do I expand this so I get further sheets with the ranges where the cell contents was "C" or "M"?

I tried setting rngOut to the first blank cell in the next sheet;

Set rngOut = wbkOut.Sheets(2).Cells(1, Columns.Count).End(xlToLeft).Offset(, 1)

And then launching an essentially identical sub that ifs for the next value i want, but it doesn't like that above code, tells me rngOut is "empty".

What incredibly dense mistake am I making here?

Or, even better, can I get it to read all the ranges and then divide them in to separate sheets for every value that is in that cell?

**pike** · 02-25-2010, 06:00 AM

I dont follow?

**WaveOfMutilation** · 02-25-2010, 06:34 AM

Sorry, what I need to do overall is to pluck this particular range from all these workbooks and then divide them up between the sheets of a new workbook according to the contents of a particular cell.

Attached is an example of the sheets I am pulling teh data from, with the important cell highlighted in red.

Hope this helps.

Cheers

Matt

**WaveOfMutilation** · 02-25-2010, 09:58 AM

Bumped. A bit rude of me but I could really use a solution in the short term, doesn't need to be pretty...

Cheers

**pike** · 02-25-2010, 04:46 PM

Thats ok i was asleep .. I check it out tonight

**pike** · 02-26-2010, 03:27 AM

Hi WaveOfMutilation
something along the lines of

Sub ProcessWorkbook(wbk As Workbook, rngDest As Range)
    Dim Letter As String
    Letter = Sheets(2).Range("A1")
    Select Case Letter
    Case "A"
        wbk.Sheets(2).Range("A1:A30").Copy
        rngDest.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    Case "C"

    Case "M"

    Case Else

    End Select


End Sub

**WaveOfMutilation** · 02-26-2010, 07:39 AM

Hi pike,

Thanks for that, I think I am now very nearly there - for a short-term solution anyway.

I am currently using the below code, gets pretty ugly towards the end I know, but it is nearly doing the job;

Sub DoProcessing()
    ProcessAllWorkbooksInFolder "K:\Cndadm\Pulse Survey Test", "Training*.xls", False
End Sub
Sub ProcessAllWorkbooksInFolder(strParentFolder As String, Optional strFilter As String = "*.xls", Optional blnDoSubFolders As Boolean = False)
    
    Dim FS As FileSearch
    Dim lngCounter As Long
    Dim wbk As Workbook
    Dim wbkOut As Workbook
    
    Application.ScreenUpdating = False
    
    Set wbkOut = ActiveWorkbook
    
    Set FS = Application.FileSearch
    With FS
        .NewSearch
        .LookIn = strParentFolder
        .SearchSubFolders = blnDoSubFolders
        .Filename = strFilter
        .MatchTextExactly = True
        .FileType = msoFileTypeExcelWorkbooks
        .Execute
        
        ' Loop through all the found files
        For lngCounter = 1 To .FoundFiles.Count
            Set wbk = Workbooks.Open(.FoundFiles(lngCounter))
            ProcessWorkbook wbk, wbkOut
            wbk.Close False
        Next lngCounter
        
        Set wbk = Nothing
    End With
    Set FS = Nothing
    Application.ScreenUpdating = True
End Sub

Sub ProcessWorkbook(wbk As Workbook, wbkDest As Workbook)
    
    Dim Letter As String
    Dim rngDest As Range
            
    Letter = wbk.Sheets("Results").Range("A2")
    Select Case Letter
    Case "A"
        Set rngDest = wbkDest.Sheets("A").Cells(2, Columns.Count).End(xlToLeft).Offset(, 1)
        wbk.Sheets(2).Range("A1:A30").Copy
        rngDest.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    Case "C"
        Set rngDest = wbkDest.Sheets("C").Cells(2, Columns.Count).End(xlToLeft).Offset(, 1)
        wbk.Sheets(2).Range("A1:A30").Copy
        rngDest.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    Case "M"
        Set rngDest = wbkDest.Sheets("M").Cells(2, Columns.Count).End(xlToLeft).Offset(, 1)
        wbk.Sheets(2).Range("A1:A30").Copy
        rngDest.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    Case Else
        Set rngDest = wbkDest.Sheets("Else").Cells(2, Columns.Count).End(xlToLeft).Offset(, 1)
        wbk.Sheets(2).Range("A1:A30").Copy
        rngDest.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    End Select


End Sub

Problem is, I am getting an "automation error" first runthrough of the loop when it tries to set rngDest if the target worksheet is completely blank. If I manually stick something in column A it is fine but it would be nice to avoid that.

Cheers

Matt

**pike** · 02-26-2010, 08:06 AM

try adding a case for the blank

    Case ""
     Exit Sub

or

if not isblank(Letter) then
 Select Case Letter
    Case "A"

**WaveOfMutilation** · 02-26-2010, 08:20 AM

Sorry, I think I explained that wrong. The problem occurs when the sheet I am copying the range to is completely blank.

**pike** · 02-26-2010, 08:28 AM

use this to limit the columns to 1

Cells(2,applicalion.worksheetfunction.max(1,Columns.Count))

**WaveOfMutilation** · 02-26-2010, 09:10 AM

Hi, tried that and it has got rid of my automation error, but now each range that goes in to a particular sheet is overwriting the previous one. Any ideas?

Cheers

Matt

**pike** · 02-26-2010, 05:09 PM

Its ruff

Case "A"
set  icol  =   wbkDest.Sheets("A").Cells(2, Columns.Count).End(xlToLeft)
        Set rngDest = wbkDest.Sheets("A").Cells(2, application.worksheetfunction.max(1,icol).Offset(, 1)
        wbk.Sheets(2).Range("A1:A30").Copy
        rngDest.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    Case "C"

I'll have another look when I wakeup after a swim .. surfs up

**WaveOfMutilation** · 03-01-2010, 09:25 AM

Tried that, unfortunately the second copy to a sheet is still overwriting the first

My current full code is below, and I've attached all my test workbooks in case there is something in there I should of mentioned but haven't.

Many thanks for all the help thus far.

Cheers

Matt

Sub DoProcessing()
    ProcessAllWorkbooksInFolder "K:\Cndadm\Pulse Survey Test", "Training*.xls", False
End Sub
Sub ProcessAllWorkbooksInFolder(strParentFolder As String, Optional strFilter As String = "*.xls", Optional blnDoSubFolders As Boolean = False)
    ' Note: does not work in 2007
    
    Dim FS As FileSearch
    Dim lngCounter As Long
    Dim wbk As Workbook
    Dim wbkOut As Workbook
    
    Application.ScreenUpdating = False
    
    Set wbkOut = ActiveWorkbook
    
    Set FS = Application.FileSearch
    With FS
        .NewSearch
        .LookIn = strParentFolder
        .SearchSubFolders = blnDoSubFolders
        .Filename = strFilter
        .MatchTextExactly = True
        .FileType = msoFileTypeExcelWorkbooks
        .Execute
        
        For lngCounter = 1 To .FoundFiles.Count
            Set wbk = Workbooks.Open(.FoundFiles(lngCounter))
            ProcessWorkbook wbk, wbkOut
            wbk.Close False
        Next lngCounter
        
        Set wbk = Nothing
    End With
    Set FS = Nothing
    Application.ScreenUpdating = True
End Sub

Sub ProcessWorkbook(wbk As Workbook, wbkDest As Workbook)
    
    Dim Letter As String
    Dim rngDest As Range
    
            
    Letter = wbk.Sheets("Results").Range("A2")
    Select Case Letter
    Case "A"
        Set icol = wbkDest.Sheets("A").Cells(2, Columns.Count).End(xlToLeft)
        Set rngDest = wbkDest.Sheets("A").Cells(2, Application.WorksheetFunction.Max(1, icol)).End(xlToLeft).Offset(, 1)
        wbk.Sheets(2).Range("A1:A30").Copy
        rngDest.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    Case "C"
        Set icol = wbkDest.Sheets("C").Cells(2, Columns.Count).End(xlToLeft)
        Set rngDest = wbkDest.Sheets("C").Cells(2, Application.WorksheetFunction.Max(1, icol)).End(xlToLeft).Offset(, 1)
        wbk.Sheets(2).Range("A1:A30").Copy
        rngDest.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    Case "M"
        Set icol = wbkDest.Sheets("M").Cells(2, Columns.Count).End(xlToLeft)
        Set rngDest = wbkDest.Sheets("M").Cells(2, Application.WorksheetFunction.Max(1, icol)).End(xlToLeft).Offset(, 1)
        wbk.Sheets(2).Range("A1:A30").Copy
        rngDest.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    Case Else
        Set icol = wbkDest.Sheets("Else").Cells(2, Columns.Count).End(xlToLeft)
        Set rngDest = wbkDest.Sheets("Else").Cells(2, Application.WorksheetFunction.Max(1, icol)).End(xlToLeft).Offset(, 1)
        wbk.Sheets(2).Range("A1:A30").Copy
        rngDest.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    End Select


End Sub

**romperstomper** · 03-01-2010, 09:32 AM

Is this what you want?

Sub ProcessWorkbook(wbk As Workbook, wbkDest As Workbook)
    
    Dim Letter As String
    Dim rngDest As Range
    Dim wksDest As Worksheet
    Dim iCol As Long
            
    Letter = wbk.Sheets("Results").Range("A2")
    Select Case Letter
    Case "A", "C", "M"
        Set wksDest = wbkDest.Sheets("A")
    Case Else
        Set wksDest = wbkDest.Sheets("Else")
    End If
    iCol = wbkDest.Sheets("C").Cells(2, Columns.Count).End(xlToLeft).Column
    Set rngDest = wksDest.Cells(2, Application.WorksheetFunction.Max(1, iCol)).End(xlToLeft).Offset(, 1)
    wbk.Sheets(2).Range("A1:A30").Copy
    rngDest.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False


End Sub

**WaveOfMutilation** · 03-01-2010, 10:54 AM

Quick question - is there a reason why icol is defined from Sheets("C") rather than wksDest? Will this still work if there is more or fewer columns of data in Sheet C than the other sheets?

Longer problem - second time it gets to case A, it still overwrites the data we got first time round.

**romperstomper** · 03-01-2010, 10:59 AM

Originally Posted by WaveOfMutilation

Quick question - is there a reason why icol is defined from Sheets("C") rather than wksDest?

Yes - because I'm sloppy and posted air code! It should be wksDest.

Longer problem - second time it gets to case A, it still overwrites the data we got first time round.

Is that still the case if you make the above adjustment?

Note: I assume you intended to copy to the next blank column, not row?

**WaveOfMutilation** · 03-01-2010, 11:07 AM

Unfortunately yes, it seems to be pasting them both in to column B.

Yes, did I say row somewhere? That's me being sloppy.. Personally i think it's an admirable trait in a programmer...

**romperstomper** · 03-01-2010, 11:22 AM

If you don't have data in row 2, you will keep pasting to the same column until you do, then you will move across one.
Does this version work:

Sub ProcessWorkbook(wbk As Workbook, wbkDest As Workbook)
    Dim Letter As String
    Dim rngDest As Range
    Dim wksDest As Worksheet
    Dim iCol As Long
    
    Letter = wbk.Sheets("Results").Range("A2").Value
    Select Case Letter
        Case "A", "C", "M"
            Set wksDest = wbkDest.Sheets(Letter)
        Case Else
            Set wksDest = wbkDest.Sheets("Else")
    End Select
    With wksDest
        If Len(.Cells(2, 1).Value) = 0 Then
            iCol = 1
        Else
            iCol = .Cells(2, .Columns.Count).End(xlToLeft).Column + 1
        End If
        Set rngDest = .Cells(2, iCol)
    End With
    wbk.Sheets(2).Range("A1:A30").Copy
    rngDest.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
End Sub

**WaveOfMutilation** · 03-01-2010, 11:34 AM

It's very pretty (you should see the amount of utter rubbish that is commented out of my macro now), but it has the same problem.

The good news is I worked out why.

The bad news is it's painfully silly and obvious and if I'd spotted it before now possibly pretty much everything you guys have come up with since Thursday would have worked...

wbk.Sheets(2).Range("A2:A30").Copy

So thanks for your time and... erm... sorry...

Incidentally, is there a way of doing this where I don't have to tell it what the possible contents for that cell are and the code will create sheets for every different thing that is in there?

**romperstomper** · 03-01-2010, 12:58 PM

Originally Posted by WaveOfMutilation

Incidentally, is there a way of doing this where I don't have to tell it what the possible contents for that cell are and the code will create sheets for every different thing that is in there?

Yes - I'd basically have a separate function that determines which sheet to output to using an error handler to create it if it doesn't exist. Something like (another air code alert):

Function GetSheet(wbk as workbook, strName as string) as Worksheet
Dim wksOut as worksheet
On error Resume next
set wksOut = wbk.Worksheets(strname)
on error goto 0
if wksOut is nothing then
 set wksOut = wbk.Sheets.add
wksout.name = strName
End if
set getsheet = wksOut
End Function

Copy a range to different sheets depending on first cell contents

LinkBack

Thread Tools

Rate This Thread

Display

Hybrid View

Copy a range to different sheets depending on first cell contents

Re: Copy a range to different sheets depending on first cell contents

Re: Copy a range to different sheets depending on first cell contents

Re: Copy a range to different sheets depending on first cell contents

Re: Copy a range to different sheets depending on first cell contents

Re: Copy a range to different sheets depending on first cell contents

Re: Copy a range to different sheets depending on first cell contents

Re: Copy a range to different sheets depending on first cell contents

Re: Copy a range to different sheets depending on first cell contents

Re: Copy a range to different sheets depending on first cell contents

Re: Copy a range to different sheets depending on first cell contents

Re: Copy a range to different sheets depending on first cell contents

Re: Copy a range to different sheets depending on first cell contents

Re: Copy a range to different sheets depending on first cell contents

Re: Copy a range to different sheets depending on first cell contents

Re: Copy a range to different sheets depending on first cell contents

Re: Copy a range to different sheets depending on first cell contents

Re: Copy a range to different sheets depending on first cell contents

Re: Copy a range to different sheets depending on first cell contents

Re: Copy a range to different sheets depending on first cell contents

Re: Copy a range to different sheets depending on first cell contents

Re: Copy a range to different sheets depending on first cell contents

Thread Information

Users Browsing this Thread

Bookmarks

Bookmarks

Posting Permissions