The below code thanks to @FaneDuru helped me copying filtered data to a new sheet, what I need to tweak is copying each set of data with a separate header instead of one main header for all data and also cut data instead of copy
Code:
Sub CopyFilteredCustomersByCompanyNames()
Dim wb As Workbook, ws As Worksheet, lastR As Long, wsComp As Worksheet, dictC As Object
Dim rngFilt As Range, arrCust() As Variant, arrFilt, i As Long
arrCust = Array("108169651", "108169651", "108169430", "108169430", "108168704", "108169596") 'place here the 10 specific customers name
Set wb = ActiveWorkbook 'use here the workbook you need
Set ws = ActiveSheet 'use here the necessary sheet (the one to be processed)
If ws.FilterMode Then ws.ShowAllData
Set rngFilt = ws.Range("A1").CurrentRegion: ' Debug.Print rngFilt.Address: Stop
arrFilt = rngFilt.Value2 'place the range in an array for faster iteration
'extract the uneque Company Names:
Set dictC = CreateObject("Scripting.Dictionary")
For i = 2 To UBound(arrFilt)
If arrFilt(i, 1) <> "" Then
dictC(arrFilt(i, 1)) = dictC(arrFilt(i, 1)) 1
End If
Next i
Application.ScreenUpdating = False 'optimization to make code faster
Dim keyC As Variant, rngF As Range
For Each keyC In dictC.Keys 'iterate between dictionary keys (A:A company names)
rngFilt.AutoFilter 1, keyC 'first filter by dict key
rngFilt.AutoFilter 4, arrCust, xlFilterValues 'second by array of customers numbers
Set wsComp = Nothing
'insert the necessary sheets, name them (if not existing), clear if existing and copy the filtered range
Application.EnableEvents = False: Application.Calculation = xlCalculationManual
Application.AutomationSecurity = msoAutomationSecurityForceDisable
On Error Resume Next
Set wsComp = wb.Worksheets(keyC)
On Error GoTo 0
If Not wsComp Is Nothing Then
wsComp.Cells.ClearContents
Else
Set wsComp = wb.Worksheets.Add(After:=ws)
wsComp.Name = keyC
End If
rngFilt.Rows(1).Copy ' copy the headers columns width
wsComp.Range("A1").Resize(, rngFilt.Rows(1).Columns.Count).PasteSpecial xlPasteColumnWidths
On Error Resume Next
Set rngF = rngFilt.SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If Not rngF Is Nothing Then
rngF.Copy wsComp.Range("A1")
End If
ws.ShowAllData
Application.AutomationSecurity = msoAutomationSecurityByUI
Application.EnableEvents = True: Application.Calculation = xlCalculationAutomatic
Next keyC
Application.ScreenUpdating = True
MsgBox "Ready..."
End Sub
What I want data to look like (separate data by header)
Link to Faneduru profile: https://stackoverflow.com/users/2233308/faneduru
CodePudding user response：
Please, copy the next solution to a standard module (instead of the existing code):
Option Explicit
Sub CopyFilteredCustomersByCompanyNames()
Dim wb As Workbook, ws As Worksheet, lastR As Long, wsComp As Worksheet, dictC As Object
Dim rngFilt As Range, arrCust() As Variant, arrFilt, i As Long
arrCust = Array("108169651", "108169651", "108169430", "108169430", "108168704", "108169596") 'place here the 10 specific customers name
Set wb = ActiveWorkbook 'use here the workbook you need
Set ws = ActiveSheet 'use here the necessary sheet (the one to be processed)
If ws.FilterMode Then ws.ShowAllData
Set rngFilt = ws.Range("A1").CurrentRegion: ' Debug.Print rngFilt.Address: Stop
arrFilt = rngFilt.Value2 'place the range in an array for faster iteration
'extract the uneque Company Names:
Set dictC = CreateObject("Scripting.Dictionary")
For i = 2 To UBound(arrFilt)
If arrFilt(i, 1) <> "" Then
dictC(arrFilt(i, 1)) = dictC(arrFilt(i, 1)) 1
End If
Next i
Application.ScreenUpdating = False 'optimization to make code faster
Dim keyC As Variant, rngF As Range, rngF1 As Range
For Each keyC In dictC.Keys 'iterate between dictionary keys (A:A company names)
rngFilt.AutoFilter 1, keyC 'first filter by dict key
rngFilt.AutoFilter 4, arrCust, xlFilterValues 'second by array of customers numbers
Set wsComp = Nothing
'insert the necessary sheets, name them (if not existing), clear if existing and copy the filtered range
Application.EnableEvents = False: Application.Calculation = xlCalculationManual
Application.AutomationSecurity = msoAutomationSecurityForceDisable
On Error Resume Next
Set wsComp = wb.Worksheets(keyC)
On Error GoTo 0
If Not wsComp Is Nothing Then
wsComp.Cells.ClearContents
Else
Set wsComp = wb.Worksheets.Add(After:=ws)
wsComp.Name = keyC
End If
rngFilt.Rows(1).Copy ' copy the headers columns width
wsComp.Range("A1").Resize(, rngFilt.Rows(1).Columns.Count).PasteSpecial xlPasteColumnWidths
On Error Resume Next
Set rngF1 = Nothing
Set rngF1 = rngFilt.Resize(rngFilt.Rows.Count - 1).Offset(1).SpecialCells(xlCellTypeVisible):
Set rngF = rngFilt.SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If Not rngF1 Is Nothing Then
rngF.Copy wsComp.Range("A1")
InsertHeaders wsComp
Else
Application.DisplayAlerts = False
wb.Worksheets(keyC).Delete
Application.DisplayAlerts = True
End If
ws.ShowAllData
Application.AutomationSecurity = msoAutomationSecurityByUI
Application.EnableEvents = True: Application.Calculation = xlCalculationAutomatic
Next keyC
Application.ScreenUpdating = True
MsgBox "Ready..."
End Sub
Sub InsertHeaders(ws As Worksheet)
Dim rngSub As Range, lastR As Long, firstAddress As String, rngUnion As Range
Dim i As Long, dict As Object
'check if more than one unique Account exists:
lastR = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
Set dict = CreateObject("Scripting.Dictionary")
For i = 2 To lastR
dict(ws.Cells(i, 4).Value) = vbNullString
Next i
If dict.Count < 2 Then Exit Sub 'for only one customer code, no need of other headers...
'sort the range:
ws.UsedRange.Sort key1:=ws.UsedRange.Cells(1, 4), Order1:=xlAscending, Header:=xlYes
'place Subtotals based on Account (customer number):
ws.UsedRange.Subtotal GroupBy:=4, Function:=xlSum, TotalList:=Array(12), _
Replace:=True, PageBreaks:=False, SummaryBelowData:=True
'delete last two rows:
lastR = ws.Cells(ws.Rows.Count, 4).End(xlUp).Row
ws.Rows(lastR - 1 & ":" & lastR).Delete: 'Stop
'place all cells containing "SUBTOTAL'" in formula in a Union Range:
Set rngSub = ws.UsedRange.Columns(12).Find(What:="SUBTOTAL", After:=ws.UsedRange.Columns(12).Cells(1), LookIn:=xlFormulas, lookat:=xlPart)
If rngSub Is Nothing Then Exit Sub
firstAddress = rngSub.Address
addToRange rngUnion, rngSub
Do
Set rngSub = ws.UsedRange.FindNext(rngSub)
addToRange rngUnion, rngSub
Loop While rngSub.Address <> firstAddress
'copy the header row to the places of Subtotals rows:
With ws.Rows("1:1")
.VerticalAlignment = xlCenter
.Copy rngUnion.EntireRow 'copy the header in all Union range
End With
'remove Subtotals (needed only temporary):
ws.UsedRange.RemoveSubtotal
End Sub
Sub addToRange(rngU As Range, rng As Range) 'sub adding the new range to a Union one...
If rngU Is Nothing Then
Set rngU = rng
Else
Set rngU = Union(rngU, rng)
End If
End Sub
Your existing code has only one modification: The new sub call:
rngF.Copy wsComp.Range("A1")
InsertHeaders wsComp
instead of
rngF.Copy wsComp.Range("A1")
Please, send some feedback after testing it.