Combining data from multiple sheets into new sheet in same workbook

julhs

Board Regular
Joined
Dec 3, 2018
Messages
80
Office Version
  1. 2010
Platform
  1. Windows
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,


VBA 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
 

Some videos you may like

Excel Facts

What is the fastest way to copy a formula?
If A2:A50000 contain data. Enter a formula in B2. Select B2. Double-click the Fill Handle and Excel will shoot the formula down to B50000.

shknbk2

Board Regular
Joined
Mar 5, 2016
Messages
248
3 errors on 2 lines:

VBA Code:
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.

VBA Code:
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:
VBA Code:
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

Well-known Member
Joined
Jun 29, 2014
Messages
1,056
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:-

VBA Code:
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

Board Regular
Joined
Dec 3, 2018
Messages
80
Office Version
  1. 2010
Platform
  1. Windows
Hi shknbk2
I had corrected,
VBA Code:
If LCase(Left(sh.Name, 10)) = "CFList_Nozz" Then
to read
VBA Code:
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!!
VBA Code:
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
 

Attachments

  • Nozzle Master snip.JPG
    Nozzle Master snip.JPG
    192.1 KB · Views: 7
  • CFList Nozz(with1).JPG
    CFList Nozz(with1).JPG
    149.8 KB · Views: 7
  • CFList Nozz(with2) snip.JPG
    CFList Nozz(with2) snip.JPG
    142 KB · Views: 7

julhs

Board Regular
Joined
Dec 3, 2018
Messages
80
Office Version
  1. 2010
Platform
  1. Windows
Need to "Bump" this as not had any more feed back for 3 days
 

julhs

Board Regular
Joined
Dec 3, 2018
Messages
80
Office Version
  1. 2010
Platform
  1. Windows
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
 
Solution

Watch MrExcel Video

Forum statistics

Threads
1,127,894
Messages
5,627,498
Members
416,250
Latest member
darius_rebelo

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top