Snasui Excel Forum

Code: Select all

Sub Macro1()
    Dim rAll As Range, r As Range
    Dim i As Integer
    Application.ScreenUpdating = False
    Range("D1:XFD" & Rows.Count).Clear
    Range("B:B").Copy Range("D:D")
    Range("D:D").RemoveDuplicates Columns:=1, Header:=xlYes
    Range("D1:D3").Insert Shift:=xlDown
    With ActiveSheet
        Set rAll = .Range("D5", .Range("D" & Rows.Count).End(xlUp))
     End With
    For Each r In rAll
        Range("D2").Formula = "=B2=" & r
        Range("A:C").AdvancedFilter Action:=xlFilterCopy, CriteriaRange:= _
            Range("D1:D2"), CopyToRange:=Range("E1").Offset(0, i)
        i = i + 4
    Next r
    Range("D:D").Clear
    Application.ScreenUpdating = True
End Sub

Code: Select all

Sub Macro2()
    Dim rAll As Range, r As Range
    Dim rSource As Range, i As Integer
    Application.ScreenUpdating = False
    Range("AH1:XFD" & Rows.Count).Clear
    Range("A12:AG12").Insert Shift:=xlDown
    Range("A12:AG12").Select
    Range("A12") = "Col1"
    Range("A12").AutoFill Destination:=Range("A12:AG12"), Type:=xlFillDefault
    Range("G:G").Copy Range("AH:AH")
    Range("AH:AH").UnMerge
    Range("AH:AH").RemoveDuplicates Columns:=1, Header:=xlYes
    Range("AH1:AH13").Insert Shift:=xlDown
    With ActiveSheet
        Set rAll = .Range("AH18", .Range("AH" & Rows.Count).End(xlUp))
        Set rSource = .Range("A12", .Range("A" & Rows.Count).End(xlUp)).Resize(, 33)
     End With
    For Each r In rAll
        Range("AH12").Formula = "=G13=" & r
        With ActiveSheet
            rSource.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:= _
            .Range("AH11:AH12"), CopyToRange:=.Range("AI11").Offset(0, i)
            .Range("AI1").Offset(0, i).Resize(11, 33) = .Range("A1:AG11").Value
            i = i + 34
        End With
    Next r
    Range("AH:AH").Clear
    Range("A12:AG12").Delete Shift:=xlUp
    Application.ScreenUpdating = True
End Sub

Code: Select all

Sub Macro2()
    Dim rAll As Range, r As Range
    Dim rSource As Range, i As Integer
    Application.ScreenUpdating = False
    Range("AH1:XFD" & Rows.Count).Clear
    Range("A12:AG12").Insert Shift:=xlDown
    Range("A12:AG12").Select
    Range("A12") = "Col1"
    Range("A12").AutoFill Destination:=Range("A12:AG12"), Type:=xlFillDefault
    Range("G:G").Copy Range("AH:AH")
    Range("AH:AH").UnMerge
    Range("AH:AH").RemoveDuplicates Columns:=1, Header:=xlYes
    Range("AH1:AH13").Insert Shift:=xlDown
    With ActiveSheet
        Set rAll = .Range("AH18", .Range("AH" & Rows.Count).End(xlUp))
        Set rSource = .Range("A12", .Range("A" & Rows.Count).End(xlUp)).Resize(, 33)
     End With
    For Each r In rAll
        Range("AH12").Formula = "=G13=" & r
        With ActiveSheet
            rSource.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:= _
            .Range("AH11:AH12"), CopyToRange:=.Range("AI11").Offset(0, i)
            .Range("AI1").Offset(0, i).Resize(11, 33) = .Range("A1:AG11").Value
            i = i + 34
        End With
    Next r
    Range("AH:AH").Clear
    Range("A12:AG12").Delete Shift:=xlUp
    Application.ScreenUpdating = True
End Sub

Code: Select all

Sub Macro2()
    Dim rAll As Range, r As Range
    Dim rSource As Range
    Dim lRow1 As Long, lRow2 As Long
    Application.ScreenUpdating = False
    Range("AH1:XFD" & Rows.Count).Clear
    Range("A12:AG12").Insert Shift:=xlDown
    Range("A12:AG12").Select
    Range("A12") = "Col1"
    Range("A12").AutoFill Destination:=Range("A12:AG12"), Type:=xlFillDefault
    Range("G:G").Copy Range("AH:AH")
    Range("AH:AH").UnMerge
    Range("AH:AH").RemoveDuplicates Columns:=1, Header:=xlYes
    Range("AH1:AH13").Insert Shift:=xlDown
    With ActiveSheet
        Set rAll = .Range("AH18", .Range("AH" & Rows.Count).End(xlUp))
        Set rSource = .Range("A12", .Range("A" & Rows.Count).End(xlUp)).Resize(, 33)
     End With
    For Each r In rAll
        Range("AH12").Formula = "=G13=" & r
        With ActiveSheet
            If .Range("AI1") = "" Then
                lRow = 1
            Else
                lRow = .Range("AI" & Rows.Count).End(xlUp).Row + 5 'Change 5 to the value what you want
            End If
            .Range("AI" & lRow).Resize(11, 33) = .Range("A1:AG11").Value
            lRow2 = .Range("AI" & Rows.Count).End(xlUp).Row + 1
            rSource.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:= _
            .Range("AH11:AH12"), CopyToRange:=.Range("AI" & lRow2)
        End With
    Next r
    Range("AH:AH").Clear
    Range("A12:AG12").Delete Shift:=xlUp
    Application.ScreenUpdating = True
End Sub

Code: Select all

Sub FormatPainter()
    Range("A1:AG11").Select
    Selection.Copy
    Range("AI1").Select
    Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    Application.CutCopyMode = False
    Selection.Copy
    Range("AI21").Select
    Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    Application.CutCopyMode = False
    Selection.Copy
    Range("AI40").Select
    Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    Application.CutCopyMode = False
    Selection.Copy
    Range("AI57").Select
    Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    Application.CutCopyMode = False
    Selection.Copy
    Range("AI77").Select
    Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    Application.CutCopyMode = False
    Selection.Copy
    Range("AI97").Select
    Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    Application.CutCopyMode = False
    Range("AI1:BO1").Select
End Sub

Code: Select all

'Other code
With ActiveSheet
    If .Range("AI1") = "" Then
        lRow = 1
    Else
        lRow = .Range("AI" & Rows.Count).End(xlUp).Row + 5 'Change 5 to the value what you want
    End If
    .Range("AI" & lRow).Resize(11, 33) = .Range("A1:AG11").Value
    lRow2 = .Range("AI" & Rows.Count).End(xlUp).Row + 1
    rSource.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:= _
    .Range("AH11:AH12"), CopyToRange:=.Range("AI" & lRow2)
    .Range("AI" & lRow2).Resize(, 33).Delete shift:=xlUp
'Other code
End With

'Other code

Code: Select all

Sub FormatPainter()
    Range("A1:AG11").Select
    Selection.Copy
    Range("AI1").Select
    Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    Application.CutCopyMode = False
    Selection.Copy
    Range("AI20").Select
    Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    Application.CutCopyMode = False
    Selection.Copy
    Range("AI38").Select
    Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    Application.CutCopyMode = False
    Selection.Copy
    Range("AI54").Select
    Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    Application.CutCopyMode = False
    Selection.Copy
    Range("AI73").Select
    Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    Application.CutCopyMode = False
    Selection.Copy
    Range("AI92").Select
    Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    Application.CutCopyMode = False
    Range("AI1:BO1").Select
End Sub

Code: Select all

Sub Macro1()
    Dim rAll As Range, r As Range
    Dim rSource As Range
    Dim lRow1 As Long, lRow2 As Long
    Application.ScreenUpdating = False
    Range("AH1:XFD" & Rows.Count).Delete
    Range("A12:AG12").Insert shift:=xlDown
    Range("A12:AG12").Select
    Range("A12") = "Col1"
    Range("A12").AutoFill Destination:=Range("A12:AG12"), Type:=xlFillDefault
    Range("G:G").Copy Range("AH:AH")
    Range("AH:AH").UnMerge
    Range("AH:AH").RemoveDuplicates Columns:=1, Header:=xlYes
    Range("AH1:AH13").Insert shift:=xlDown
    With ActiveSheet
        Set rAll = .Range("AH18", .Range("AH" & Rows.Count).End(xlUp))
        Set rSource = .Range("A12", .Range("A" & Rows.Count).End(xlUp)).Resize(, 33)
    End With
    For Each r In rAll
        Range("AH12").Formula = "=G13=" & r
    With ActiveSheet
    If .Range("AI1") = "" Then
        lRow = 1
    Else
        lRow = .Range("AI" & Rows.Count).End(xlUp).Row + 5 'Change 5 to the value what you want
    End If
    .Range("AI" & lRow).Resize(11, 33) = .Range("A1:AG11").Value
    lRow2 = .Range("AI" & Rows.Count).End(xlUp).Row + 1
    rSource.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:= _
    .Range("AH11:AH12"), CopyToRange:=.Range("AI" & lRow2)
    .Range("AI" & lRow2).Resize(, 33).Delete shift:=xlUp
        End With
    Next r
    Range("AH:AH").Clear
    Range("A12:AG12").Delete shift:=xlUp
    Application.ScreenUpdating = True
End Sub

Code: Select all

'Other code
With ActiveSheet
    If .Range("AI1") = "" Then
        lRow = 1
    Else
        lRow = .Range("AI" & Rows.Count).End(xlUp).Row + 5 'Change 5 to the value what you want
    End If
    .Range("A1:AG11").Copy .Range("AI" & lRow).Resize(11, 33)
    lRow2 = .Range("AI" & Rows.Count).End(xlUp).Row + 1
    rSource.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:= _
    .Range("AH11:AH12"), CopyToRange:=.Range("AI" & lRow2)
    .Range("AI" & lRow2).Resize(, 33).Delete shift:=xlUp
End With
'Other code