Hello there attached is your example worksheet update to include a macro that I believe accomplishes what you are looking for. To run the macro. Press Alt+F8 on your keyboard and select the test macro and then select the run option.
Please note that this code assumes that your Master worksheet is the first worksheet in your workbook.
It also assumes that the rest of the worksheet in your workbook are worksheets you wanted copied into the Master worksheet.
To insert this code
1. Press Alt+F8 on your keyboard
2. Clear the macro name field
3. Type the following in the macro name field AddToMaster
4. Select the Create option
5. In between the Sub AddToMaster() and End Sub copy and paste the following code, anything that appears in green is a comment meant to help you understand
'declare variables
Dim Darr() As String, c As Range, LR As String, d As Long, x As String
Dim ws As Worksheet, rFound As Range, FindAny As Range, y As Long
With Sheets(2) 'with the second worksheet in the workbook (in this case source1)
.Select 'select the worksheet
LR = .Range("A6555").End(xlUp).Row 'set LR equal to the last row that contains a value
For Each c In .Range("A2:A" & LR).Cells 'loop through cells in column A from row 2 to the last row
If c.Value <> vbNullString Then 'if the curret cell in the loop is not empty then
If x = vbNullString Then 'if x is not yet defined then
x = c.Value 'set x equal to the current cell in the loop's value
Else 'if x is defined then
x = x & ";" & c.Value 'set x equal to the previous value of x
'combined with the current cell in the loops value
'seperated by a ;
End If 'end the if x statement
End If 'end the c.value statement
Next c 'move to next cell in the loop until the last row
End With 'end with the second worksheet in the workbook
Darr = Split(x, ";") 'defined Darr array (a list) as all the values of x
For d = LBound(Darr) To UBound(Darr) 'loop through the variable d from the first
'item in the list to the last
For Each ws In ThisWorkbook.Worksheets 'loop through the worksheet in the workbook
If ws.Index > 1 Then 'if the worksheet is not the first worksheet then (aka the master worksheet)
On Error Resume Next
With ws 'with the current worksheet in the loop
LR = .Range("B6555").End(xlUp).Row 'set LR equal to the last row in the B column that contains a value
.Range("A" & LR + 1).Value = "End" 'place the word End in
'Column A the row after the last row
'set rfound equal to the found cell in column a whose value
'is the first list item in the darr list (for this example the first
'list item would be config
Set rFound = .Columns(1).Find(What:=Darr(d), After:=.Cells(1, 1), LookIn:=xlValues, LookAt:= _
xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
, SearchFormat:=False)
On Error GoTo 0
'set findany equal to the first non empty cell after the rfound cell (defined above)
Set FindAny = .Columns(1).Find(What:="*", After:=rFound)
If ws.Index = 2 Then 'if the worksheet is the second worksheet in the workbook then
'copy the cells in column A through I from the rfound row
'to the row above the findany row
'this includes the header row
.Range("A" & rFound.Row & ":I" & FindAny.Row - 1).Copy
y = 2 'set y=2 to start new section
Else
'copy the cells in column A through I from the row below the rfound row
'to the row above the findany row
'this excludes the header row because it has already been placed
.Range("A" & rFound.Row + 1 & ":I" & FindAny.Row - 1).Copy
y = 1 'set y = 1 to add to current section
End If
With Sheets("Master") 'with the worksheet Master
LR = .Range("B6555").End(xlUp).Row + y 'set LR equal to the last used row in column B plus y(defined above)
.Range("A" & LR).PasteSpecial 'paste the copied values
End With 'end with the master worksheet
End With 'end with the current worksheet in the loop
End If 'end if the worksheet not the first worksheet
Next ws 'move to next worksheet in the loop
Next d 'move to next list item in the Darr list
7. Close out of VBA and then press Alt+F8 again
8. Select the AddToMaster macro and select Run.
Let me know if this works for you!
Thanks!
LinkBack URL
About LinkBacks
Register To Reply
icon below to give reputation feedback, it is appreciated.
Bookmarks