Thursday, 24 September 2015

Copy excel rows to separate sheets based on a column value

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