Use the full code below and amend newFileName value to whatever you are using
Amendments made to code (with explanations):
1. this line speeds up the running of the code - screen is now only updated at the end of the macro when the same property is reverted to true
Application.ScreenUpdating = False
2. this filters to show only those rows where the name count = 1 (these rows are subsequently deleted)
rng.AutoFilter Field:=1, Criteria1:="1", Operator:=xlFilterValues
3. this bit of code:
- starts with the last row and
- works backwards through name values (names are currently in column C due to temporary formulas)
- blank row and headers inserted if name differs from name above
- does not need to do that at row 2 because the header is already there (Exit For tells vba to exit the current For loop)
- where possible always step backwards through the rows when deleting or inserting rows
(if delete/insert starting at top then row numbers below are changed each time and that would have to be built into the VBA - "i" would require resetting)
For i = r To 2 Step -1
If r = 2 Then Exit For
copyRng.Copy
If .Cells(i, 3) <> .Cells(i - 1, 3) Then
.Cells(i, 1).EntireRow.Insert Shift:=xlDown
Application.CutCopyMode = xlCopy
.Rows(i).Insert
End If
Next i
full code:
Sub CopyRowsIfNameAppears5Times()
Application.ScreenUpdating = False
'variables, path and file names
Dim wb As Workbook, wbNew As Workbook, wsNew As Worksheet, ws As Worksheet
Dim wbNamesArr, myPath As String, wbName As String, newFileName As String, c As String
Dim n As Integer, r As Long, i As Long
Dim rng As Range, copyRng As Range
wbNamesArr = Array("List_1", "Arba_let2", "Expedia1", "Expedia2", "Book3")
myPath = "d:\Documents\HR_ProfileBooks" & "\"
If Right(myPath, 1) = "\" Then myPath = Left(myPath, Len(myPath) - 1)
'create new file
newFileName = "MyFileName" & Format(Now, "hh mm ss") 'amend to suit
Set wbNew = Workbooks.Add
wbNew.SaveAs (myPath & "\" & newFileName)
Set wsNew = wbNew.Worksheets(1)
'open each file in turn
For n = 0 To UBound(wbNamesArr)
wbName = myPath & "\" & wbNamesArr(n) & ".xlsx"
Set wb = Workbooks.Open(wbName)
Set ws = wb.Worksheets(1)
'add header row to new file
If n = 0 Then ws.Rows("1:1").Copy Destination:=wsNew.Range("A1")
'copy sheet values and paste to new file
r = ws.Range("A" & Cells.Rows.Count).End(xlUp).Row
Set copyRng = ws.Rows("2:" & r)
copyRng.Copy Destination:=wsNew.Range("A" & Cells.Rows.Count).End(xlUp).Offset(1)
wb.Close
Next n
With wsNew
r = .Range("A" & Cells.Rows.Count).End(xlUp).Row
'insert temporary working columns
.Columns("A:B").Insert Shift:=xlToRight
'insert temporary formulas
For i = 2 To r
.Range("A" & i).Formula = "=COUNTIF(C2:C" & r & ",C" & i & ")"
.Range("B" & i).Value = i
Next i
c = .Cells(1, wsNew.Cells.Columns.Count).End(xlToLeft).Address(0, 0)
Set rng = .Range("A1:" & c).Resize(r)
'remove all rows where count of names is not equal to 5
rng.AutoFilter Field:=1, Criteria1:="1", Operator:=xlFilterValues
rng.Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete
rng.AutoFilter
'sort by name
r = .Range("A" & Cells.Rows.Count).End(xlUp).Row
Set copyRng = wsNew.Rows("1:1")
Set rng = .Range("A1:" & c).Resize(r)
rng.Sort Key1:=.Range("C1"), Header:=xlYes
'insert header for each "name" and a blank row in between each name block
For i = r To 2 Step -1
If r = 2 Then Exit For
copyRng.Copy
If .Cells(i, 3) <> .Cells(i - 1, 3) Then
.Cells(i, 1).EntireRow.Insert Shift:=xlDown
Application.CutCopyMode = xlCopy
.Rows(i).Insert
End If
Next i
'delete temporary column
.Columns("A:B").Delete
End With
Application.ScreenUpdating = True
'save the file
wbNew.Save
End Sub
Bookmarks