Macro to combine worksheets into a new worksheet in same workbook

[Nieriel]

Hi All,

I am hoping you can help me - I have found a couple of macros on this board and a few other sites but I can't seem to amend them to get them to work for my workbook - the problem is I have found bits of code from various macros and tried to put them together in one and failed miserably so thinking starting from scratch maybe better.

I have a spreadsheet template that is filled out by others each week and sent back to me.

I am trying to get a macro that will combine data off the tabs onto one main sheet in the same workbook - my current macro creates a new tab called 'WeekCombined'

The 1st two tabs have lists of data that are used for data lists on all the other tabs - these are hidden so I tried to add into the macro that it looked at visible sheets only (however this did keep throwing an error)

The data I wish to copy on all the other tabs starts in the same row (8) and the columns are always A-L, I want to copy the headers from the 1st visible tab (so A7-L7) then just the data (starting in row 8) for the remaining tabs.

The main issue I am having is that every tab can have a varied number of rows (so some will just have row 8 with data in, others will have data all the way to row 88)

I tried to find a macro to copy up to the last row which contains data, however column L contains a formula (my template has this formula to row 58 - they insert more rows if needed and copy the formula down), and therefore the macro always pulls to rows 8-58 despite the rest of the row being empty.

Is there macro that will do all of the above but only copy the row A-L if there is data in column A?

Any help/advice would be greatly appreciated,

Kind Regards
Melissa

 

[Brombrough]

Hi Melissa,

Come across this a lot.

I use following, you can modify this to suit your needs:

Dim lngMaxRow As Long

'(I don't use current range as if there is a blank row it doesn't find anything after blank row)
'So I go all the way to the bottom and then come up till I find data in that column this is my last row
' this will help you with variable row lengths

lngMaxRow = Sheets("Sheet Name Here").Range("L1048576").End(xlUp).Row

For Each cell In Sheets("Sheet Name Here").Range("A2:A" & lngMaxRow)
'do action as required
Next


Hope this helps.

 

[dmt32]

Hi,
without see your code I was going to suggest if you have not already tried it,using the following to find last row in range

LastRow = Columns("A").Find("*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows, LookIn:=xlValues).Row

which is a common suggestion & works in most cases.

However, before I posted thought would do a little research & came across this post here:https://www.mrexcel.com/forum/excel-questions/468964-find-last-row-vba-ignoring-formula-blanks.html

Which offers an interesting alternative in post #7 which you may find useful if above does not do what you want.

An alternative suggestion to what you are doing would be if all your users have access on your corporate network to a common file, have the templates write the data directly to it - this would negate need to consolidate any files.


Dave

 

[Nieriel]

Thank you very much, unfortunately my macro skills extend as far as modifying ones I find online so I am not sure where this would fit into my current code but looking at it I think I could change the function? (I have detailed the current macro and functions being used below)
Also - I keep getting an ambiguous name error on 'LastRow' however when I tested this code on the example workbook supplied it worked fine - I haven't changed anything in the functions or last row just modified the ranges etc.

Functions:
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


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

Macro

Sub CopyDataWithoutHeaders()
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

'Delete the sheet "Weekcombined’ if already exists
Application.DisplayAlerts = False
On Error Resume Next
ActiveWorkbook.Worksheets("WeekCombined").Delete
On Error GoTo 0
Application.DisplayAlerts = True

'Add a worksheet with the name "WeekCombined"
Set DestSh = ActiveWorkbook.Worksheets.Add
DestSh.Name = "WeekCombined"

StartRow = 8

'loop through all visible worksheets and copy the data to the DestSh
For Each sh In ActiveWorkbook.Worksheets
If sh.Name <> DestSh.Name And sh.Visible = True Then

'Copy header rowIf WorksheetFunction.CountA(DestSh.UsedRange) = 0 Then sh.Range("A7:L7").Copy DestSh.Range("A1")End If
'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 the range that you 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 and formats
CopyRng.Copy
With DestSh.Cells(Last + 1, "A")
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
Application.CutCopyMode = False
End With

End If

End If
Next

ExitTheSub:

Application.Goto DestSh.Cells(1)

'AutoFit the column width in the DestSh sheet
DestSh.Columns.AutoFit

With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub

 

[Nieriel]

Thank you all - I have been playing around with a couple of suggestions and amended the Function code to dmt32's suggestion - my macro is now running without any errors but it is only pulling the Headers onto the new tab and no data - I think amending the function has fixed the ambiguous name detected error but maybe knocked something else out?

Functions:

Function LastRow(sh As Worksheet)
On Error Resume Next
LastRow = Columns("A").Find("*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows, LookIn:=xlValues).Row
On Error GoTo 0
End Function

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

Macro:

Sub CopyDataWithHeaders()
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

Application.DisplayAlerts = False
On Error Resume Next
ActiveWorkbook.Worksheets("WeekCombined").Delete
On Error GoTo 0
Application.DisplayAlerts = True

Set DestSh = ActiveWorkbook.Worksheets.Add
DestSh.Name = "WeekCombined"

StartRow = 8

For Each sh In ActiveWorkbook.Worksheets
If sh.Name <> DestSh.Name And sh.Visible = True Then

If WorksheetFunction.CountA(DestSh.UsedRange) = 0 Then
sh.Range("A7:L7").Copy DestSh.Range("A1")
End If

Last = LastRow(DestSh)
shLast = LastRow(sh)

If shLast > 0 And shLast >= StartRow Then

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

If Last + CopyRng.Rows.Count > DestSh.Rows.Count Then
MsgBox "There are not enough rows in the Destsh"
GoTo ExitTheSub
End If

CopyRng.Copy
With DestSh.Cells(Last + 1, "A")
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
Application.CutCopyMode = False
End With

End If

End If
Next

ExitTheSub:

Application.Goto DestSh.Cells(1)

DestSh.Columns.AutoFit

With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub

 

[dmt32]

Hi,
you need to qualify the range with the range object argument otherwise, code just returns the activeworkheet result

Function LastRow(sh As Worksheet)
On Error Resume Next
LastRow = sh.Columns("A").Find("*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows, LookIn:=xlValues).Row
On Error GoTo 0
End Function

Dave

 

[Nieriel]

Thanks Dave - however as soon as I add this back in I'm back to my Compile Error: Ambiguous name detected: LastRow

Takes me to this part of the Macro - I can't see that it's duplicated anywhere else in the macro?

If WorksheetFunction.CountA(DestSh.UsedRange) = 0 Then
sh.Range("A7:L7").Copy DestSh.Range("A1")
End If


Last = LastRow(DestSh)
shLast = LastRow(sh)

 

[dmt32]

Do you have another copy the Function Lastrow elsewhere in your project?


Dave

 

[Nieriel]

Thank you so much!!!! I had hidden the Project Explorer whilst editing and completely forgot to check if the old function was in there!

Perfect thank you so much for all your help!

 

[dmt32]

Thank you so much!!!! I had hidden the Project Explorer whilst editing and completely forgot to check if the old function was in there!

Perfect thank you so much for all your help!

Glad resolved.

Dave