Combining data from multiple sheets into new sheet in same workbook

[julhs]

I have tried customising a Ron de Braun code for my needs but I’m obviously missed something!!

Trying to produce a new sheet "CF_Nozz_Combined" that is populated from sheets "CFList_Nozz(with1)", "CFList_Nozz(with2)" etc

All data in "CFList_Nozz(with1) etc is;
Headers in A1:H1, data in A2:H2 on all sheets., but unknown # of rows

Results I’m getting at moment are:-
The existing sheet "CF_Nozz_Combined" is deleted and a new one produced, but is blank


This is my adapted code,

Function LastRow(sh As Worksheet)

On Error Resume Next

LastRow = sh.Cells.Find(What:="*", _

After:=sh.Range("A1"), _

Lookat:=xlPart, _

LookIn:=xlFormulas, _

SearchOrder:=xlByRows, _

SearchDirection:=xlPrevious, _

MatchCase:=False).Row

On Error GoTo 0

End Function

_________________________________________________________________________

Sub CopyRangeFromMultiWorksheets()

Dim sh As Worksheet

Dim DestSh As Worksheet

Dim Last As Long

Dim shLast As Long

Dim CopyRng As Range

Dim StartRow As Long



With Application

.ScreenUpdating = False

.EnableEvents = False

End With



'To Delete the sheet "CF_Nozz_Combined" if it exist

Application.DisplayAlerts = False

On Error Resume Next

ActiveWorkbook.Worksheets("CF_Nozz_Combined").Delete

On Error GoTo 0

Application.DisplayAlerts = True



'Add a NEW worksheet with the name "CF_Nozz_Combined"

Set DestSh = ActiveWorkbook.Worksheets.Add

DestSh.Name = "CF_Nozz_Combined"



StartRow = 2



'looping through worksheets that start "CFList_Nozz " and copy the data to the DestSh

For Each sh In ActiveWorkbook.Worksheets

If LCase(Left(sh.Name, 10)) = "CFList_Nozz" Then



'Find the last row with data on the DestSh and sh

Last = LastRow(DestSh)

shLast = LastRow(sh)



'If sh is not empty and if the last row >= StartRow copy the CopyRng

If shLast > 0 And shLast >= StartRow Then



‘Set Range want to copy

Set CopyRng = sh.Range(sh.Rows(StartRow), sh.Rows(shLast))



'Test if there enough rows in the DestSh to copy all the data

If Last + CopyRng.Rows.Count > DestSh.Rows.Count Then

MsgBox "There are not enough rows in the Destsh"

GoTo ExitTheSub

End If

‘Copy values, Set to Copy values/formats,

CopyRng.Copy

With DestSh.Cells(Last + 1, "A")

.PasteSpecial xlPasteValues

.PasteSpecial xlPasteFormats

Application.CutCopyMode = False

End With

End If

'This will copy the sheet name in the J column

DestSh.Cells(Last + 1, "J").Resize(CopyRng.Rows.Count).Value = sh.Name

End If

Next

ExitTheSub:



'All the rest of stuff required

Application.Goto DestSh.Cells(1)

With Application

.ScreenUpdating = True

.EnableEvents = True

End With

End Sub

 

[shknbk2]

3 errors on 2 lines:

Function LastRow(sh As Worksheet)

The function needs to return a value. Since you're setting Last and shLast based on the function, and since they are longs, add " As Long" after the function name.

If LCase(Left(sh.Name, 10)) = "CFList_Nozz" Then

2 errors: First, "CFList_Nozz" is 11 characters, not 10.
Second, LCase of the sheet name is "cflist_nozz" (no caps)

Entire code here:

Function LastRow(sh As Worksheet) As Long
    On Error Resume Next
    LastRow = sh.Cells.Find(What:="*", _
        After:=sh.Range("A1"), _
        Lookat:=xlPart, _
        LookIn:=xlFormulas, _
        SearchOrder:=xlByRows, _
        SearchDirection:=xlPrevious, _
        MatchCase:=False).Row
    On Error GoTo 0
End Function

Sub CopyRangeFromMultiWorksheets()
    Dim sh As Worksheet
    Dim DestSh As Worksheet
    Dim Last As Long
    Dim shLast As Long
    Dim CopyRng As Range
    Dim StartRow As Long

    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With

    'To Delete the sheet "CF_Nozz_Combined" if it exist
    Application.DisplayAlerts = False
    On Error Resume Next
    ActiveWorkbook.Worksheets("CF_Nozz_Combined").Delete
    On Error GoTo 0
    Application.DisplayAlerts = True
    
    'Add a NEW worksheet with the name "CF_Nozz_Combined"
    Set DestSh = ActiveWorkbook.Worksheets.Add
    DestSh.Name = "CF_Nozz_Combined"
    
    StartRow = 2
    
    'looping through worksheets that start "CFList_Nozz " and copy the data to the DestSh
    For Each sh In ActiveWorkbook.Worksheets
        If LCase(Left(sh.Name, 11)) = "cflist_nozz" Then
            'Find the last row with data on the DestSh and sh
            Last = LastRow(DestSh)
            shLast = LastRow(sh)
            
            'If sh is not empty and if the last row >= StartRow copy the CopyRng
            If shLast > 0 And shLast >= StartRow Then
            
                'Set Range want to copy
                Set CopyRng = sh.Range(sh.Rows(StartRow), sh.Rows(shLast))
                
                'Test if there enough rows in the DestSh to copy all the data
                If Last + CopyRng.Rows.Count > DestSh.Rows.Count Then
                    MsgBox "There are not enough rows in the Destsh"
                    GoTo ExitTheSub
                End If
                'Copy values, Set to Copy values/formats,
                CopyRng.Copy
                With DestSh.Cells(Last + 1, "A")
                    .PasteSpecial xlPasteValues
                    .PasteSpecial xlPasteFormats
                    Application.CutCopyMode = False
                End With
            End If
            'This will copy the sheet name in the J column
            DestSh.Cells(Last + 1, "J").Resize(CopyRng.Rows.Count).Value = sh.Name
        End If
    Next
ExitTheSub:
    'All the rest of stuff required
    Application.Goto DestSh.Cells(1)
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
End Sub

 

[vcoolio]

Hello Julhs,

As far as I understand your opening post, you are wanting to consolidate all source sheet data in one main destination sheet named "CF_Nozz_Combined".
There is no need to continually delete/create a new main sheet. The same sheet can always be used, just cleared when a new data transfer needs to be done.

A simple subroutine as follows should be all that you need:-

Sub Test()

Dim ws As Worksheet, wsCFN As Worksheet
Set wsCFN = Sheets("CF_Nozz_Combined")

Application.ScreenUpdating = False
       
wsCFN.UsedRange.Offset(1).Clear

        For Each ws In Worksheets
                If ws.Name <> "CF_Nozz_Combined" Then
                       ws.UsedRange.Offset(1).Copy wsCFN.Range("A" & Rows.Count).End(3)(2)
                End If
        Next ws

Application.ScreenUpdating = True

End Sub

So, manually create a new main sheet named "CF_Nozz_Combined" then place the above code into a standard module and assign it to a button.

I hope that this helps.

Cheerio,
vcoolio.

 

[julhs]

Hi shknbk2
I had corrected,

If LCase(Left(sh.Name, 10)) = "CFList_Nozz" Then

to read

If LCase(Left(sh.Name, 11)) = "CFList_Nozz" Then

after I posted. Have now corrected other 2 errors you pointed out.
Unfortunately result is still a new Blank sheet "CF_Nozz_Combined"

I have been testing changing actual sheet names, “CFList_Nozz(with1) to “CFList_Nozz_(with1) etc and the use of a wildcard, with no success.

But if I understand it correctly!!

If LCase(Left(sh.Name, 11)) = "cflist_nozz" Then

Just looks for sheets that START with "cflist_nozz" anyway

Just to clarify; sheets “CFList_Nozz(with1) & “CFList_Nozz(with2) are simiply lists of Condition Formating on “Nozzle Master” sheet.

Have posted images of what you’re actually dealing with

 

[julhs]

Need to "Bump" this as not had any more feed back for 3 days

 

[julhs]

Whole reason for the blank sheet was caused by an inaccurately named sheet in the “looping” procedure.

I had used the “_” in "cflist_nozz" thinking I needed to due to sheet name having a space in its actual name.
As soon as changed "cflist_nozz" to "cflist nozz" then it worked!!

Oh so simple an oversight, caused no end of frustration

Now able to mark tread as solved