Snasui Excel Forum

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("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
        
    Next r
    Range("AH:AH").Clear
    Range("A12:AG12").Delete shift:=xlUp
    Application.ScreenUpdating = True
End Sub

Code: Select all

Sub Sep()
Dim header As Range
Dim signature As Range

Sheets("ListEx").Range("AH:BZ").Clear
Set header = Range("A1:AG11")
Set signature = Sheets("Nsch").Range("H2:AN3")

srcRowNum = Sheets("List").Range("G" & Rows.Count).End(xlUp).Row
For itemRw = 12 To srcRowNum
If WorksheetFunction.CountIf(Range("G12:G" & itemRw), Cells(itemRw, "G").Value) = 1 Then
Cells(itemRw, "AH") = WorksheetFunction.Max(Range("AH:AH")) + 1
End If
Next itemRw

numOfItem = WorksheetFunction.Max(Range("AH:AH"))
For itemNo = 1 To numOfItem
selItem = Range("G" & WorksheetFunction.Match(itemNo, Range("AH:AH"), 0)).Value
targetRow = Range("AI" & Rows.Count).End(xlUp).Row + 10
header.Copy
Range("AI" & targetRow).PasteSpecial xlPasteAll
For Each sameItem In Range("G12:G" & srcRowNum)
If sameItem = selItem Then
Range("A" & sameItem.Row & ":AG" & sameItem.Row).Copy
Range("AI" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteAll
End If
Next sameItem
firstRwSameItem = targetRow + 11
LastRwSameItem = Range("AI" & Rows.Count).End(xlUp).Row
fmlRw1 = targetRow + 9
fmlRw2 = targetRow + 10
For fmlCol = 49 To 66
Cells(fmlRw1, fmlCol) = WorksheetFunction.Sum(Range(Cells(firstRwSameItem, fmlCol).Address & ":" & Cells(LastRwSameItem, fmlCol).Address))
Cells(fmlRw2, fmlCol) = Cells(fmlRw1, fmlCol) * 3
Next fmlCol
Sheets("ListEx").Range("BL" & targetRow + 4).FormulaR1C1 = "=VLOOKUP(R[7]C[-23],name,2,0)"
signature.Copy
Sheets("ListEx").Range("AI" & Rows.Count).End(xlUp).Offset(2, 0).PasteSpecial xlPasteAll
Next itemNo
    Columns("AH:AH").Select
    Selection.ClearContents
    Range("AI1:BO10").Select
    Selection.Delete Shift:=xlUp
    Range("AI1:BO1").Select
End Sub

Code: Select all

Sub Macro2()
    Application.ScreenUpdating = False
    
    Range("A1:AG11").Select
    Selection.Copy
    Range("AI1:BO1").Select
    Selection.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False

    Dim rAll As Range, r As Range
    Dim rSource As Range
    Dim lRow1 As Long, lRow2 As Long
    Dim header As Range

    
    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 Signature = Sheets("name").Range("H2:AN3")
        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 + 10 '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" & lRow).Resize(11, 33) = .Range("AI" & lRow).Resize(11, 33).Value 'Add this line
    .Range("AI" & lRow2).Resize(, 33).Delete shift:=xlUp
    End With
    
    targetRow = Range("AI" & Rows.Count).End(xlUp).Row + 10
    Sheets("List").Range("BL" & targetRow + 7).FormulaR1C1 = "=VLOOKUP(R[5]C[-23],name,2,0)"
    Signature.Copy
    Sheets("List").Range("AI" & Rows.Count).End(xlUp).Offset(2, 0).PasteSpecial xlPasteAll
    
    Next r
    Range("AH:AH").Clear
    Range("A12:AG12").Delete shift:=xlUp
    
        Range("A1:AG11").Select
        Selection.Copy
        Range("AI1:BO1").Select
        Selection.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
            SkipBlanks:=False, Transpose:=False
        Range("AI1:BO1").Select
        Application.CutCopyMode = False

    Application.ScreenUpdating = True
End Sub

Code: Select all

    Sheets("List").Range("BL" & targetRow + 7).FormulaR1C1 = "=VLOOKUP(R[5]C[-23],name,2,0)"

Code: Select all

    Sheets("List").Range("BL" & targetRow + 7).FormulaR1C1 = "=VLOOKUP(R[5]C[-23],name,2,0)"