Excel Forum

Code: Select all

Sub Macro1()
    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
       Range("A1:AG1").Select
        Application.ScreenUpdating = True
End Sub

Code: Select all

Sub FormatTable()
Application.ScreenUpdating = False
   Range("AD7:AG7").Select
    ActiveCell.FormulaR1C1 = "=VLOOKUP(R[5]C[-23],name,2,0)"
    Dim i As Integer, j As Integer
    j = Sheets("List").UsedRange.Columns.Count
    Range("A1:AG11").Copy
    For i = 35 To j Step 34
            Sheets("List").Cells(1, i).PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
        ActiveSheet.Paste
    Selection.PasteSpecial Paste:=xlPasteFormats
    Next i
    Application.CutCopyMode = False
    Range("AD7:AG7").Select
    ActiveCell.FormulaR1C1 = "=name!R[-6]C[-29]"
    Range("A1:AG1").Select
    Application.ScreenUpdating = True
End Sub

Code: Select all

Sub SubSelectTable()
    Dim i As Integer, j As Integer, r As Range
    Set r = Sheets("List").Range("A1")
    With Sheets("List")
        j = .UsedRange.Columns.Count
        For i = 1 To j Step 34
            Set r = Union(r, Range(.Cells(1, i).CurrentRegion.Resize(.Cells(1, i) _
                .CurrentRegion.Rows.Count + 10).Address))
        Next i
        r.Select
     End With
End Sub

Code: Select all

Sub RunAllCode()
   Call Macro1
   Call FormatTable
   Call SubSelectTable
End Sub

Code: Select all

CreateFolder7470()
CreateFolder2530()