Option Explicit
Sub Fr33M4cro()
Dim sh33tName As String
Dim custNameColumn As String
Dim i As Long
Dim stRow As Long
Dim customer As String
Dim ws As Worksheet
Dim sheetExist As Boolean
Dim sh As Worksheet
sh33tName = "All data (2)"
custNameColumn = "C" 'the column where it will take values as filter
stRow = 2
Set sh = Sheets(sh33tName)
For i = stRow To sh.Range(custNameColumn & Rows.Count).End(xlUp).Row
customer = sh.Range(custNameColumn & i).Value
For Each ws In ThisWorkbook.Sheets
If StrComp(ws.Name, customer, vbTextCompare) = 0 Then
sheetExist = True
Exit For
End If
Next
If sheetExist Then
CopyRow i, sh, ws, custNameColumn
Else
InsertSheet customer
Set ws = Sheets(Worksheets.Count)
CopyHeaderRow 1, sh, ws, custNameColumn
CopyRow i, sh, ws, custNameColumn
End If
Reset sheetExist
Next i
SetFormat
End Sub
Private Sub SetFormat()
Dim ws As Worksheet
For Each ws In Worksheets
With ws
.Cells.Font.Size = 8
End With
Next ws
End Sub
Private Sub CopyRow(i As Long, ByRef sh As Worksheet, ByRef ws As Worksheet, custNameColumn As String)
Dim wsRow As Long
wsRow = ws.Range(custNameColumn & Rows.Count).End(xlUp).Row + 1
sh.Rows(i & ":" & i).Copy
' set row height to 18px
ws.Rows(wsRow & ":" & wsRow).PasteSpecial Paste:=xlPasteFormats
ws.Rows(wsRow & ":" & wsRow).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
ws.Rows(wsRow & ":" & wsRow).RowHeight = 13.5
Application.CutCopyMode = False
End Sub
Private Sub CopyHeaderRow(i As Long, ByRef sh As Worksheet, ByRef ws As Worksheet, custNameColumn As String)
Dim wsRow As Long
Rows("2:2").Select
ActiveWindow.FreezePanes = True
ActiveSheet.Range("A1:AA1").Select
With Selection
.WrapText = True
.VerticalAlignment = xlCenter
.HorizontalAlignment = xlCenter
.AutoFilter
End With
wsRow = ws.Range(custNameColumn & Rows.Count).End(xlUp).Row
sh.Rows(i & ":" & i).Copy
ws.Rows(wsRow & ":" & wsRow).PasteSpecial Paste:=xlPasteFormats
ws.Rows(wsRow & ":" & wsRow).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
ws.Rows(wsRow & ":" & wsRow).WrapText = True
ws.Rows(wsRow & ":" & wsRow).VerticalAlignment = xlCenter
ws.Rows(wsRow & ":" & wsRow).HorizontalAlignment = xlCenter
ws.Rows(wsRow & ":" & wsRow).Font.Bold = True
ws.Rows(wsRow & ":" & wsRow).Font.Size = 10
Application.CutCopyMode = False
End Sub
Private Sub Reset(ByRef x As Boolean)
x = False
End Sub
Private Sub InsertSheet(shName As String)
Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = shName
End Sub
No comments:
Post a Comment