Excel: Populate Data Across Multiple Worksheets - excel

Unfortunately for my employer, none of my network engineering courses included advanced Excel formula programming. Needless to say, I know nothing about Excel save for basic SUM and COUNT formula commands.
My employer has an Excel workbook with multiple worksheets within it representing each month of the calendar year. We want to be able to have a "total" worksheet in the workbook that reflects all data across the entire workbook in each column/row.
An example for the sake of clarity:
In the worksheet "May_2013", column A is labeled "DATE". Cell A2 contains the data "MAY-1".
In the worksheet "June_2013", column A is labeled "DATE". Cell A2 contains the data "JUNE-1".
In the worksheet "Total", column A is labeled "DATE". We want cells A2 to reflect "MAY-1" and A3 to reflect "JUNE-1".
We want to do this for all worksheets, columns A-Q, rows 2-33 and populate a master sheet at the very end containing all data in all worksheets in their corresponding columns.
Is this possible?

Here are two VBA solutions. The first does this:
Check if a sheet "totals" exists. Create it if it does not
Copy the first row (A to Q) of first sheet to "totals"
Copy block A2:Q33 to "totals" sheet starting at row 2
Repeat for all other sheets, appending 32 rows lower each time
The second shows how to do some manipulation of the column data before copying: for each column it applies the WorksheetFunction.Sum(), but you could replace that with any other aggregating function that you would like to use. It then copies the result (one row per sheet) to the "totals" sheet.
Both solutions are in the workbook you can download from this site. Run the macros with , and pick the appropriate one from the list of options that shows up. You can edit the code by invoking the VBA editor with .
Sub aggregateRaw()
Dim thisSheet, newSheet As Worksheet
Dim sheetCount As Integer
Dim targetRange As Range
sheetCount = ActiveWorkbook.Sheets.Count
' add a new sheet at the end:
If Not worksheetExists("totals") Then
Set newSheet = ActiveWorkbook.Sheets.Add(after:=Sheets(sheetCount))
newSheet.Name = "totals"
Else
Set newSheet = ActiveWorkbook.Sheets("totals")
End If
Set targetRange = newSheet.[A1]
' if you want to clear the sheet before copying data, uncomment this line:
' newSheet.UsedRange.Delete
' assuming you want to copy the headers, and that they are the same
' on all sheets, you can copy them to the "totals" sheet like this:
ActiveWorkbook.Sheets(1).Range("1:1").Copy targetRange
Set targetRange = targetRange.Offset(1, 0) ' down a row
' copy blocks of data from A2 to Q33 into the "totals" sheet
For Each ws In ActiveWorkbook.Worksheets
If ws.Name <> newSheet.Name Then
ws.Range("A2", "Q33").Copy targetRange
Set targetRange = targetRange.Offset(32, 0) ' down 32 rows
End If
Next ws
End Sub
Sub aggregateTotal()
Dim thisSheet, newSheet As Worksheet
Dim sheetCount As Integer
Dim targetRange As Range
Dim columnToSum As Range
sheetCount = ActiveWorkbook.Sheets.Count
' add a new sheet at the end:
If Not worksheetExists("totals") Then
Set newSheet = ActiveWorkbook.Sheets.Add(after:=Sheets(sheetCount))
newSheet.Name = "totals"
Else
Set newSheet = Sheets("totals")
End If
' assuming you want to copy the headers, and that they are the same
' on all sheets, you can copy them to the "totals" sheet like this:
Set targetRange = newSheet.[A1]
ActiveWorkbook.Sheets(1).Range("A1:Q1").Copy targetRange
Set targetRange = targetRange.Offset(1, 0) ' down a row
For Each ws In ActiveWorkbook.Worksheets
' don't copy data from "total" sheet to "total" sheet...
If ws.Name <> newSheet.Name Then
' copy the month label
ws.[A2].Copy targetRange
' get the sum of the coluns:
Set columnToSum = ws.[B2:B33]
For colNum = 2 To 17 ' B to Q
targetRange.Offset(0, colNum - 1).Value = WorksheetFunction.Sum(columnToSum.Offset(0, colNum - 2))
Next colNum
Set targetRange = targetRange.Offset(1, 0) ' next row in output
End If
Next ws
End Sub
Function worksheetExists(wsName)
' adapted from http://www.mrexcel.com/forum/excel-questions/3228-visual-basic-applications-check-if-worksheet-exists.html
worksheetExists = False
On Error Resume Next
worksheetExists = (Sheets(wsName).Name <> "")
On Error GoTo 0
End Function
Final(?) edit:
If you want this script to run automatically every time someone makes a change to the workbook, you can capture the SheetChange event by adding code to the workbook. You do this as follows:
open the Visual Basic editor ()
In the project explorer (left hand side of the screen), expand the VBAProject
Right-click on "ThisWorkbook", and select "View Code"
In the window that opens, copy/paste the following lines of code:
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
' handle errors gracefully:
On Error GoTo errorHandler
' turn off screen updating - no annoying "flashing"
Application.ScreenUpdating = False
' don't respond to events while we are updating:
Application.EnableEvents = False
' run the same sub as before:
aggregateRaw
' turn screen updating on again:
Application.ScreenUpdating = True
' turn event handling on again:
Application.EnableEvents = True
Exit Sub ' if we encountered no errors, we are now done.
errorHandler:
Application.EnableEvents = True
Application.ScreenUpdating = True
' you could add other code here... for example by uncommenting the next two lines
' MsgBox "Something is wrong ... " & Err.Description
' Err.Clear
End Sub

Kindly use RDBMerge add-in which will combine the data from different worksheet and create a master sheet for you. Please see the below link for more details.
http://duggisjobstechnicalstuff.blogspot.in/2013/03/how-to-merge-all-excel-worksheets-with.html
Download RDBMerge

You can use the indirect function to reference the sheet name. In the image below this function takes the header name (B37) and uses it as the sheet reference. All you have to do is choose the correct "total cell" which I made "A1" in "MAY_2013". I put an image below to show you my reference name as well as tab name

Related

How to copy data from one worksheet to another to a specific row

To all,
thanks for your time in advance.
we already have working code to move data from one wrksht to another with vb in excel.
we use:
Set lastrow = Sheets ("SR log").Cells(Rows.Count, 1).End(x1UP)
With LastRow
This places our selected data on the last open row of sheet 2
Is it possible to , instead of the last row, Search for a reference number from the first sheet that is already on the second sheet , lets say Cell G3. use the information from the first sheet in cell g3 and look for it on the second sheet.
Once that row is found ( the G3 data from the first sheet will be in column A of the second sheet)
Now apply data to that row where applicable.
any help would be appreciated.
2/22/19
Here is my response.
thankyou for taking the time
I have put something together but wanted to run it by before executing
[code]
Private Sub CommandButton2_Click()
Workbooks.Open Filename:="G:\General\COVER SHEET_Protective\Protective Packaging Order Log.xlsm", Password:="PP", WriteResPassword:="PP"
Dim FoundRow As Variant
FoundRow = Application.Match(Sheets(1).Range("G3"), Sheets(2).Columns(1), 0)
If IsNumeric(FoundRow) Then
With FoundRow
' found, use FoundRow like LastRow before
End With
Else
' not found :(
End If
.Offset(1).Font.Size = 14
.Offset(1, 9) = ws.[I10]
.Offset(1, 10) = ws.[I11]
End Sub
[/code]
I'm am a little unsure about this row
[code]
Application.Match(Sheets(1).Range("G3"), Sheets(2).Columns(1), 0)
[/code]
the match sheets 1 on the first workbook is called worksheet
and on the second workbook where the search is happening on the first
column
the sheet is called orderlog
thanks
You can find the matching row with Application.Match:
Private Sub CommandButton2_Click()
Dim wb1 As Workbook ' first workbook
Dim wb2 As Workbook ' second workbook
Dim wsCheck As Worksheet ' sheet in the first workbook
Dim wsOrderlog As Worksheet ' sheet in the second workbook
' address the first workbook and its sheet
' if this VBA-code is in the frist workbook, it's "ThisWorkbook"
Set wb1 = ThisWorkbook
Set wsCheck = wb1.Worksheets("Worksheet")
' check, if second workbook is already open
For Each wb2 In Workbooks
If wb2.Name = "Protective Packaging Order Log.xlsm" Then Exit For
Next wb2
' if not already open, then open it, and address its sheet also
If wb2 Is Nothing Then
Set wb2 = Workbooks.Open( _
Filename:="G:\General\COVERSHEET_Protective\Protective Packaging Order Log.xlsm", _
Password:="PP", _
WriteResPassword:="PP")
End If
Set wsOrderlog = wb2.Worksheets("orderlog")
' search a value from the first workbook's sheet within second workbook's sheet
Dim FoundRow As Variant
FoundRow = Application.Match(wsCheck.Range("G3").Value, wsOrderlog.Range("A:A"), 0)
If IsNumeric(FoundRow) Then ' if found
' please adapt to your needs:
wsOrderlog.Cells(FoundRow, 1).Font.Size = 14
wsOrderlog.Cells(FoundRow, 9).Value = wsCheck.Range("I10").Value
wsOrderlog.Cells(FoundRow, 10).Value = wsCheck.Range("I11").Value
Else
MsgBox "Sorry, the value in cell G3" & vbLf & _
wsCheck.Range("G3").Value & vbLf & _
"could not be found in orderlog column A."
End If
' close the second workbook (Excel will ask, if to save)
wb2.Close
End Sub

Excel VBA copy row automatically

I need help to create an automatic method to copy a row to a specific sheet.
I have a Tab (Sales) with a WEB api query importing data in this sheet every 5 min. I have a row within the Sales sheet with a name range identifying each item. The row has 100 different names and there are 100 sheets created with same names within the workbook.
I want to copy the entire row for each item and copy it to the sheet with the same name of the item.
This is to fire off the copy sub:
'Copy Sales data Every 10 Min
Sub test()
'Application.OnTime Now + TimeValue("00:10:00"), "my_Procedure…"
End Sub
I have seen many methods on how to copy the row automatically, but I need help in copy row and use the item name and paste to other sheet with same name.
Without further information here is an outline of what i described in the comments. Here the list of named ranges starts at cell J3 in NamesSheet. In the image, i have shown it in the same sheet (SourceSheet for simplicity). The list is read into an array and that array is looped to select the appropriate sheet to set the values in.
Rather than copy and paste it sets the target row (the next available row), in the sheet accessed by the array index, equal to the source row (copyRow). A With statement is used to avoid selecting the target sheet (more efficient).
No error handling added for missing sheets at present.
I haven't assumed there will be a list of 100 named ranges in the sheet, otherwise you could have sized the array from the start.
Named ranges in ColA of Sales tab:
List of named ranges in Names sheet (abbreviated)
Option Explicit
Private Sub myProc()
Dim wb As Workbook
Dim wsSource As Worksheet
Dim wsNames As Worksheet
Set wb = ThisWorkbook
Set wsSource = wb.Worksheets("Sales")
Set wsNames = wb.Worksheets("Names")
Dim namesArr()
namesArr = wsNames.Range("J3:J" & wsNames.Cells(wsNames.Rows.Count, "J").End(xlUp).Row).Value
If UBound(namesArr, 1) <> wsSource.Range("ITEMName").Rows.Count Then
MsgBox "There are not a matching number of named ranges listed in Names sheet."
Exit Sub
End If
Dim i As Long
Dim currLastRow As Long
'Any optimization code could actually go in outer calling sub but consider
'some such as the following
Application.ScreenUpdating = False
Dim copyRow As Range
For i = LBound(namesArr, 1) To UBound(namesArr, 1)
With wb.Worksheets(namesArr(i, 1))
Set copyRow = wsSource.Range(namesArr(i, 1)).EntireRow
If IsEmpty(.Range("A1")) Then 'First row in sheet is available
.Rows(1).Value = copyRow.Value2
Else
currLastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
.Rows(currLastRow + 1).Value = copyRow.Value2
End If
End With
Next i
Application.ScreenUpdating = True
End Sub
Version 2:
Looping Named Ranges in Sales sheet (assumes only 101 Named Ranges in the sheet, tested with workbook scope, and that you will ignore 1 of these which is called ITEMName, no list required in a different sheet. Approach adapted from #user1274820.
Option Explicit
Private Sub myProc2()
Dim wb As Workbook
Dim wsSource As Worksheet
Set wb = ThisWorkbook
Set wsSource = wb.Worksheets("Sales")
Dim currLastRow As Long
'Any optimization code could actually go in outer calling sub but consider
'some such as the following
Application.ScreenUpdating = False
Dim copyRow As Range
Dim nm As Variant
For Each nm In ThisWorkbook.Names
If nm.RefersToRange.Parent.Name = "Sales" And nm.Name <> "ITEMName" Then
With wb.Worksheets(nm.Name)
Set copyRow = wsSource.Range(nm.Name).EntireRow
If IsEmpty(.Range("A1")) Then 'First row in sheet is available
.Rows(1).Value = copyRow.Value2
Else
currLastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
.Rows(currLastRow + 1).Value = copyRow.Value2
End If
End With
End If
Next nm
Application.ScreenUpdating = True
End Sub

How to loop through multiple worksheets with a sub that is already looping?

So I've got this sub I've pieced together that runs through all tabs in my workbook looking for a specific name, then copies all that data into a single sheet, at the next empty row.
Basically combining a bunch of similar sheets with same column format.
So my question is how do I modify this to loop through multiple groups of sheets? Right now, this is coded to only work for sheets named like "Group1" and copy into a single sheet called "raw_Group1".
How do I modify to then also look for "Group2", ... "GroupN"? The grouping name is not actually numbered, but something like "people" "stuff" "orders" etc. Each group has a different column structure and multiple sheets that I'm trying to combine.
Sub copy_Group1()
Dim ws As Worksheet
Dim Destws As Worksheet
Dim Last As Long
Dim wsLast As Long
Dim CopyRng As Range
Dim StartRow As Long
'This keeps the screen from updating until the end, makes the macro run faster
Application.ScreenUpdating = False
Application.DisplayAlerts = False
'defines an existing "Raw_Group1" worksheet instead of creating a new one
Set Destws = ActiveWorkbook.Sheets("Raw_Group1")
'clears sheet first, leaving headers
Destws.Rows("2:" & Rows.Count).ClearContents
'Fill in the start row.
StartRow = 2
'Loop through all worksheets and copy the data to the summary worksheet.
For Each ws In ActiveWorkbook.Worksheets
If LCase(ws.Name) Like "group1*" Then
'Find the last row with data on the summary and source worksheets.
Last = LastRow(Destws)
wsLast = LastRow(ws)
'If source worksheet is not empty and if the last row >= StartRow, copy the range.
If wsLast > 0 And wsLast >= StartRow Then
'Specify the range to place the data. Four options for specifying the range
''Set CopyRng = sh.Range("A1:G1") 'whole block of columns
''Set CopyRng = ws.Range("A1:B" & LastRow) 'specific columns, to the last row
''Set CopyRng = ws.Range("B1").CurrentRegion 'uses the current block of data
Set CopyRng = ws.Range(ws.Rows(StartRow), ws.Rows(wsLast)) 'Set the range starting at row2
'Test to see whether there are enough rows in the summary worksheet to copy all the data.
If Last + CopyRng.Rows.Count > Destws.Rows.Count Then
MsgBox "There are not enough rows in the " & _
"summary worksheet to place the data."
GoTo ExitTheSub
End If
CopyRng.Copy ' This statement copies values and formats.
'paste values only
With CopyRng
Destws.Cells(Last + 1, "A").Resize(.Rows.Count, _
.Columns.Count).Value = .Value
End With
End If
End If
Next
ExitTheSub:
Application.Goto Destws.Cells(1)
'filter: turns off then on (resets)
If Destws.AutoFilterMode Then Destws.AutoFilterMode = False
Destws.Range("A1").AutoFilter
'AutoFit the column width in the summary sheet.
Destws.Columns.AutoFit
'turns screen updating back on
Application.ScreenUpdating = True
End Sub
Consider generalizing your workbook processing for each group by setting up parameters into your macro with following changed lines. If certain groups need specific processing use conditional If or Select Case blocks for those particular parameter values:
Sub copy_Group(group_name As Variant, dest_sheet As Variant)
...
Set Destws = ActiveWorkbook.Sheets(dest_sheet)
...
If LCase(ws.Name) Like group_name & "*" Then
...
End Sub
And then in another macro iteratively pass all pairs of group names and destination sheets when calling your above macro. Add accordingly if you need other parameters like Start_Row and even use other data structures (i.e., collection, dictionary) instead of anonymous nested array.
Sub RunLoop()
Dim var As Variant
For Each var In Array(Array("group1", "Raw_Group1"), Array("people", "ppl_dest"), _
Array("stuff", "stuff_dest"), Array("orders", "order_dest"), _
Array("other", "other_dest"))
Call copy_Group(var(0), var(1))
Next var
End Sub
Of course there's no reason you cannot embed this loop in previous macro but this may help in code organization, even abstraction between the steps.
Hmm...#parfait...So I tried your advice here. It kinda works, but doesn't seem to be passing the 'group name' (the 1st 'type') to the first if-statement
Sub RunLoop()
Dim var As Variant
For Each var In Array( _
Array("stuff", "Raw_stuff"), _
Array("people", "Raw_people"), _
Array("orders", "Raw_orders"))
Call copy_Group(var(0), var(1)) 'calls sub listed below
Next var
End Sub
=====================
Sub copy_Group(group_name As Variant, dest_sheet As Variant)
Dim ws As Worksheet
Dim Destws As Worksheet
Dim Last As Long
Dim wsLast As Long
Dim CopyRng As Range
Dim StartRow As Long
'This keeps the screen from updating until the end, makes the macro run faster
Application.ScreenUpdating = False
Application.DisplayAlerts = False
'defines an existing worksheet instead of creating a new one
Set Destws = ActiveWorkbook.Sheets(dest_sheet)
'clears sheet first, leaving headers
Destws.Rows("2:" & Rows.Count).ClearContents
'Fill in the start row.
StartRow = 2
'Loop through all worksheets and copy the data to the summary worksheet.
For Each ws In ActiveWorkbook.Worksheets
If LCase(ws.Name) Like group_name & "*" Then
'Find the last row with data on the summary and source worksheets.
Last = LastRow(Destws)
wsLast = LastRow(ws)
'If source worksheet is not empty and if the last row >= StartRow, copy the range.
If wsLast > 0 And wsLast >= StartRow Then
'Specify the range to place the data. Four options for specifying the range
''Set CopyRng = sh.Range("A1:G1") 'whole block of columns
''Set CopyRng = ws.Range("A1:B" & LastRow) 'specific columns, to the last row
''Set CopyRng = ws.Range("B1").CurrentRegion 'uses the current block of data
Set CopyRng = ws.Range(ws.Rows(StartRow), ws.Rows(wsLast)) 'Set the range starting at row2
'Test to see whether there are enough rows in the summary worksheet to copy all the data.
If Last + CopyRng.Rows.Count > Destws.Rows.Count Then
MsgBox "There are not enough rows in the " & _
"summary worksheet to place the data."
GoTo ExitTheSub
End If
CopyRng.Copy ' This statement copies values and formats.
'paste values only
With CopyRng
Destws.Cells(Last + 1, "A").Resize(.Rows.Count, _
.Columns.Count).Value = .Value
End With
End If
End If
Next
ExitTheSub:
Application.Goto Destws.Cells(1)
'filter: turns off then on (resets)
If Destws.AutoFilterMode Then Destws.AutoFilterMode = False
Destws.Range("A1").AutoFilter
'AutoFit the column width in the summary sheet.
Destws.Columns.AutoFit
'turns screen updating back on
Application.ScreenUpdating = True
End Sub

merge worksheets that have drop-down list

I have a workbook that consists of 180 worksheets. Each worksheet has the top 9 rows and columns A1:Z1 with information that I do not need.
The rest of the worksheet has data that I do need and want to append into one worksheet. The problem is that each of the worksheet has drop-down choices embedded in them. The choices have already been made and I need to append the sheets with the choices selected.
Been trying to run a VBA script but have been unsuccessful. Any help is greatly appreciated.
Thank you
Current code that I used to remove the top rows for few of the sheets, only removal but not appending. And I have inserted sheet names, but with 180 sheets that will not be possible.
Sub remove_rows()
'
' remove_rows Macro
'
'
`Rows("1:10").Select`
`Selection.EntireRow.Hidden = False`
`Range("D20").Select`
`Rows("1:9").Select`
`Range("A9").Activate`
`Selection.Delete Shift:=xlUp`
`Sheets("BioME-Box- (2)").Select`
`Rows("1:15").Select`
`Selection.EntireRow.Hidden = False`
`Rows("1:9").Select`
`Range("A9").Activate`
`Selection.Delete Shift:=xlUp`
`Sheets("BioME-Box- (3)").Select`
`Rows("1:13").Select`
`Selection.EntireRow.Hidden = False`
Rows("1:9").Select
Range("A9").Activate
Selection.Delete Shift:=xlUp
It sounds like you are talking about Validation lists as your "drop down" lists. If so then they might be getting their options from a another range somewhere else. So if you delete a range that the validation lists are using then all of their options disappear. I don't know if this is your problem. But you can copy a validation list and paste only its value, not the whole list, this way.
Sub Macro1()
Range("D3").Select ' This is the validation list
Selection.Copy
' Change "SomeOtherRangeHere" to any cell you want to
Range("SomeOtherRangeHere").PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
End Sub
Try this one. Be sure to change mainWS to the worksheet you are copying to. I used sheet1 but you may be using another. In this sub it copies everything below Row 9 of all sheets and pastes them to the first available row in sheet1.
Sub Macro1()
Dim ws As Worksheet, mainWS As Worksheet
Dim wsLastRow As Long, mainWSlastRow As Long, wsLastCol As Long
Set mainWS = Sheet1 ' Change this to the sheet you are copying everthing to
For Each ws In ThisWorkbook.Worksheets
def = mainWS.Name
abc = ws.Name
If ws.Name <> mainWS.Name Then ' Make sure to not copy from the sheet yuo are copying to
wsLastRow = ws.UsedRange.Rows.Count
wsLastCol = ws.UsedRange.Columns.Count
On Error Resume Next
mainWSlastRow = Sheet1.Cells.Find("*", [A1], , , xlByRows, xlPrevious).Row
If Err.Number = 91 Then
mainWSlastRow = 1
On Error GoTo 0
End If
ws.Range("A10:" & Chr(wsLastCol + 64) & wsLastRow).Copy Destination:=mainWS.Range("A" & mainWSlastRow + 1)
End If
Next ws
Set mainWS = Nothing
Set ws = Nothing
End Sub

Combine worksheets and add column in Excel

I have a worksheet that contains multiple tabs that identify different sources of data. I need to combine all the worksheets into one and add a column with the worksheet name as part of the new combined sheet.
I found the following code and if I cut/paste into my worksheet it works like a charm BUT I have several of these workbooks and I have to be able to recreate this process monthly.
My research indicates that I should create a com add in or recallable macro to do this but each time I have tried, the process fails. I would very much appreciate if somone could point me with the steps to do this in Excel (2013) and advise me if my code will work.
Thanks in advance.
Sub Combine()
Dim J As Integer, wsNew As Worksheet
Dim rngCopy As Range, rngPaste As Range
Dim Location As String
On Error Resume Next
Set wsNew = Sheets("Combined")
On Error GoTo 0
'if sheet does not already exist, create it
If wsNew Is Nothing Then
Set wsNew = Worksheets.Add(before:=Sheets(1)) ' add a sheet in first place
wsNew.Name = "Combined"
End If
'copy headings and paste to new sheet starting in B1
With Sheets(2)
Range(.Range("A1"), .Cells(1, Columns.Count).End(xlToLeft)).Copy wsNew.Range("B1")
End With
' work through sheets
For J = 2 To Sheets.Count ' from sheet 2 to last sheet
'save sheet name/location to string
Location = Sheets(J).Name
'set range to be copied
With Sheets(J).Range("A1").CurrentRegion
Set rngCopy = .Offset(1, 0).Resize(.Rows.Count - 1)
End With
'set range to paste to, beginning with column B
Set rngPaste = wsNew.Cells(Rows.Count, 2).End(xlUp).Offset(2, 0)
'copy range and paste to column *B* of combined sheet
rngCopy.Copy rngPaste
'enter the location name in column A for all copied entries
Range(rngPaste, rngPaste.End(xlDown)).Offset(0, -1) = Location
Next J
End Sub
You can add this code into your Personal Macro Workbook, and modify it so it acts on the ActiveWorkbook. That way, when you run it, it will operate on whichever workbook is selected in Excel.
Also worth qualifying all your sheet references with a workbook object reference. When you use (e.g.):
Sheets("Combined")
then by default it will refer to the ActiveWorkbook. Usually this is what you want (though it may not be), but working this way can cause problems if (for example) you open/activate a different workbook in your code, and that other workbook is now the target of your Sheets(....) reference. You resolve this by always being explicit about which workbook you're referring to: for example -
ThisworkBook.Sheets() 'the workbook containing the running code
ActiveWorkbook.Sheets() 'the selected workbook
Workbooks("test.xlsx").Sheets() 'named workbook
wb.Sheets() 'use a variable set to a workbook object
So, modifying your existing code:
Sub Combine()
Dim wb As Workbook
Dim J As Integer, wsNew As Worksheet
Dim rngCopy As Range, rngPaste As Range
Dim Location As String
Set wb = ActiveWorkbook
On Error Resume Next
Set wsNew = wb.Sheets("Combined")
On Error GoTo 0
'if sheet does not already exist, create it
If wsNew Is Nothing Then
Set wsNew = wb.Worksheets.Add(before:=wb.Sheets(1)) ' add a sheet in first place
wsNew.Name = "Combined"
End If
'copy headings and paste to new sheet starting in B1
With wb.Sheets(2)
.Range(.Range("A1"), .Cells(1, Columns.Count) _
.End(xlToLeft)).Copy wsNew.Range("B1")
End With
' work through sheets
For J = 2 To wb.Sheets.Count ' from sheet 2 to last sheet
'save sheet name/location to string
Location = wb.Sheets(J).Name
'set range to be copied
With wb.Sheets(J).Range("A1").CurrentRegion
Set rngCopy = .Offset(1, 0).Resize(.Rows.Count - 1)
End With
'set range to paste to, beginning with column B
Set rngPaste = wsNew.Cells(Rows.Count, 2).End(xlUp).Offset(2, 0)
'copy range and paste to column *B* of combined sheet
rngCopy.Copy rngPaste
'enter the location name in column A for all copied entries
wsNew.Range(rngPaste, rngPaste.End(xlDown)).Offset(0, -1) = Location
Next J
End Sub

Resources