Snasui Excel Forum

Code: Select all

Private Sub CmdCopy_Click()
Application.ScreenUpdating = False
r = 20
For k = 11 To 160
If Sheet1.Cells(k, 10) <> "" And Sheet1.Cells(k, 2) <> "**" And Sheet1.Cells(k, 10) <> "Amt in loc" Then
    If Sheet1.Cells(k, 13) = "1000001" Then
        Sheet2.Cells(r, 2) = Sheet1.Cells(k, 2)
        Sheet2.Cells(r, 3) = Sheet1.Cells(k, 3)
        Sheet2.Cells(r, 4) = Sheet1.Cells(k, 4)
        Sheet2.Cells(r, 5) = Sheet1.Cells(k, 5)
        Sheet2.Cells(r, 6) = Sheet1.Cells(k, 6)
        Sheet2.Cells(r, 7) = Sheet1.Cells(k, 7)
        Sheet2.Cells(r, 8) = Sheet1.Cells(k, 8)
        Sheet2.Cells(r, 9) = Sheet1.Cells(k, 9)
        Sheet2.Cells(r, 10) = Sheet1.Cells(k, 10)
        Sheet2.Cells(r, 11) = Sheet1.Cells(k, 11)
        Sheet2.Cells(r, 12) = Sheet1.Cells(k, 12)
        Sheet2.Cells(r, 13) = Sheet1.Cells(k, 13)
    ElseIf Sheet1.Cells(k, 13) = "1000002" Then
        Sheet3.Cells(r, 2) = Sheet1.Cells(k, 2)
        Sheet3.Cells(r, 3) = Sheet1.Cells(k, 3)
        Sheet3.Cells(r, 4) = Sheet1.Cells(k, 4)
        Sheet3.Cells(r, 5) = Sheet1.Cells(k, 5)
        Sheet3.Cells(r, 6) = Sheet1.Cells(k, 6)
        Sheet3.Cells(r, 7) = Sheet1.Cells(k, 7)
        Sheet3.Cells(r, 8) = Sheet1.Cells(k, 8)
        Sheet3.Cells(r, 9) = Sheet1.Cells(k, 9)
        Sheet3.Cells(r, 10) = Sheet1.Cells(k, 10)
        Sheet3.Cells(r, 11) = Sheet1.Cells(k, 11)
        Sheet3.Cells(r, 12) = Sheet1.Cells(k, 12)
        Sheet3.Cells(r, 13) = Sheet1.Cells(k, 13)
    Else
        Sheet4.Cells(r, 2) = Sheet1.Cells(k, 2)
        Sheet4.Cells(r, 3) = Sheet1.Cells(k, 3)
        Sheet4.Cells(r, 4) = Sheet1.Cells(k, 4)
        Sheet4.Cells(r, 5) = Sheet1.Cells(k, 5)
        Sheet4.Cells(r, 6) = Sheet1.Cells(k, 6)
        Sheet4.Cells(r, 7) = Sheet1.Cells(k, 7)
        Sheet4.Cells(r, 8) = Sheet1.Cells(k, 8)
        Sheet4.Cells(r, 9) = Sheet1.Cells(k, 9)
        Sheet4.Cells(r, 10) = Sheet1.Cells(k, 10)
        Sheet4.Cells(r, 11) = Sheet1.Cells(k, 11)
        Sheet4.Cells(r, 12) = Sheet1.Cells(k, 12)
        Sheet4.Cells(r, 13) = Sheet1.Cells(k, 13)
    End If
End If
r = r + 1
Next
Application.ScreenUpdating = True
End Sub

Code: Select all

Private Sub CmdCopy_Click()
    Dim r As Range, r2 As Range, rSource As Range, _
        i As Integer
    With ActiveSheet
        i = Application.CountIf(.Range("a:a"), "*Vendor*")
        If i > 0 Then
            Set r2 = .Range("b1")
            For Each r In .Range("a1", .Range("a" & .Rows.Count).End(xlUp))
                If Trim(r.Value) = "Vendor" Then
                    Set r2 = .Range("b:b").Find(what:="~*~*", after:=r2)
                    i = VBA.Right(Trim(r.End(xlToRight).Value), 1)
                    If i > 0 Then
                        Set rSource = r.Resize(r2.Row - r.Row + 2, 13)
                        Sheets(i + 1).Range("a11:m1000").ClearContents
                        Sheets(i + 1).Range("a11").Resize(rSource.Rows.Count, _
                            rSource.Columns.Count).Value = rSource.Value
                    End If
                End If
            Next r
        End If
    End With
End Sub

Code: Select all

Dim rAll As Range, r As Range
Dim rSource As Range, iCount As Long
With Sheets("data")
    Set rAll = .Range("b:b").SpecialCells(xlCellTypeConstants)
    For Each r In rAll
        If r.Value = "**" Then
            r.Offset(-1, -1).Value = r.Offset(-2, 0).Value
        End If
    Next r
    Set rAll = .Range("a:a").SpecialCells(xlCellTypeConstants)
    For Each r In rAll
        If InStr(r.Value, "Vendor") Then
            Set rSource = .Range(r, r.Offset(5, 0).End(xlDown).Offset(-1, 0)).Resize(, 13)
            iCount = iCount + 1
            With Sheets(.Index + iCount)
            .UsedRange.Clear
            .Range("a1").Resize(rSource.Rows.Count, rSource.Columns.Count) _
                    .Value = rSource.Value
            End With
        End If
    Next r
End With

Code: Select all

Private Sub CommandButton2_Click()
Application.ScreenUpdating = False
Dim rAll As Range, r As Range
Dim rSource As Range, iCount As Long
With Sheets("data")
    Set rAll = .Range("b:b").SpecialCells(xlCellTypeConstants)
    For Each r In rAll
        If r.Value = "**" Then
            r.Offset(-1, -1).Value = r.Offset(-2, 0).Value
        End If
    Next r
    Set rAll = .Range("a:a").SpecialCells(xlCellTypeConstants)
    For Each r In rAll
        If InStr(r.Value, "Vendor") Then
            Set rSource = .Range(r, r.Offset(5, 0).End(xlDown).Offset(-1, 0)).Resize(, 13)
            iCount = iCount + 1
            With Sheets(.Index + iCount)
            .Range("a11:m1000").ClearContents
            .Range("a11").Resize(rSource.Rows.Count, rSource.Columns.Count) _
                    .Value = rSource.Value
            End With
        End If
    Next r
End With
Application.ScreenUpdating = True
End Sub

Code: Select all

Dim i, j, k As Long
Dim wstMain As Worksheet: Set wstMain = Worksheets("data")
Dim lngLastRow As Long: lngLastRow = wstMain.Cells(Cells.Rows.Count, 2).End(xlUp).Row
Dim strVendorCode As String
Dim lngLastrow_copy
Debug.Print wstMain.Index
wstMain.Activate
For i = 1 To lngLastRow
    If Trim(Cells(i, 1)) = "Vendor" Then
        strVendorCode = Cells(i, 6)
    For j = i To lngLastRow
        If Trim(Cells(j, 2)) = "**" Then
            lngLastrow_copy = j - 1
            Range(Cells(i, 1), Cells(lngLastrow_copy, 13)).Copy
            For k = (wstMain.Index + 1) To Sheets.Count
                If Trim(Sheets(k).Range("F2")) = strVendorCode Then
                    Sheets(k).Range("A11").PasteSpecial xlPasteValues
                    Sheets(k).Range("A11").PasteSpecial xlPasteFormats
                    Application.CutCopyMode = False
                End If
            Next
            i = j
            GoTo skipJ
        End If
    Next
    End If
skipJ:
Next
End Sub

Code: Select all

Dim rAll As Range, r As Range
Dim rSource As Range, iCount As Long
With Sheets("data")
    Set rAll = .Range("b:b").SpecialCells(xlCellTypeConstants)
    For Each r In rAll
        If r.Value = "**" Then
            r.Offset(-1, -1).Value = r.Offset(-2, 0).Value
        End If
    Next r
    Set rAll = .Range("a:a").SpecialCells(xlCellTypeConstants)
    For Each r In rAll
        If InStr(r.Value, "Vendor") Then
            Set rSource = .Range(r, r.Offset(5, 0).End(xlDown).Offset(-1, 0)).Resize(, 13)
            With Sheets("Vendor " & r.Offset(3, 5).Value)
            .Range("a11:m1000").Clear
            .Range("a11").Resize(rSource.Rows.Count, rSource.Columns.Count) _
                    .Value = rSource.Value
            End With
        End If
    Next r
End With

Code: Select all

Dim r As Range, j%, a(0 To 999, 3)
With Sheets("data")
    For Each r In .Range("a2", .Range("b" & .Rows.Count) _
        .End(xlUp)).Columns(1).Cells
        If InStr(r.Value, "Vendor") Then
            a(j, 0) = r.Row
            a(j, 1) = r.Offset(3, 5).Value
        End If
        If r.Offset(0, 1).Value = "**" Then
            a(j, 2) = r.Row - 2
            a(j, 3) = .Cells(a(j, 0), 1) _
                .Resize(a(j, 2) - a(j, 0) + 1, 13).Address
            Sheets("Vendor " & a(j, 1)).Range("a11") _
                .Resize(Range(a(j, 3)).Rows.Count, 13) _
                .Value = .Range(a(j, 3)).Value
            j = j + 1
        End If
    Next r
End With