CODEWITHSUNDEEP
vbaexcel
Kish
Kish

Reputation: 89

VBA: Build a Table by (Copy/Paste) by Using Criteria to Select Rows, Then Specifiy Columns

I want to build a table on one Excel Sheet "Ship" by pulling data from another excel sheet "Efficiency." The row data on the "Efficiency" sheet is categorized by "Shipped", "Leave", "Import" and "Export". Each category (shipped, leave, import, export) has several items and they're in no specific order. The table on the "Efficiency" sheet occupies columns A:H, and starts at row 2; the length can vary. I want to be able to search the rows for "Shipped" and copy columns A, D:F and H of the matching rows and paste them beginning at cell B4 of the "Ship" sheet. Can anyone help me please?

Sub Ship()

ActiveSheet.Range("$A$1:$H$201").AutoFilter Field:=4, Criteria1:="Shipped"
' this is looking in a specific range, I want to make it more dynamic

Range("A4:A109").Select
'This is the range selected to copy, again I want to make this part more dynamic

Application.CutCopyMode = False
Selection.Copy
Range("A4:A109,D4:F109,H4:H109").Select
Range("G4").Activate
Application.CutCopyMode = False
Selection.Copy
Sheets("Ship").Select
Range("B4").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False

End Sub

Upvotes: 1

Views: 511

Answers (2)

Scott Holtzman
Scott Holtzman

Reputation: 27259

This code has been tested based on your the information as given in your question:

Sub Ship()

Dim wsEff As Worksheet
Dim wsShip As Worksheet

Set wsEff = Worksheets("Efficiency")
Set wsShip = Worksheets("Shipped")

With wsEff

    Dim lRow As Long
    'make it dynamic by always finding last row with data
    lRow = .Range("A" & .Rows.Count).End(xlUp).Row

    'changed field to 2 based on your above comment that Shipped is in column B (the code you posted has 4).
    .Range("A1:H" & lRow).AutoFilter Field:=2, Criteria1:="Shipped"

    Dim rngCopy As Range
    'only columns A, D:F, H
    Set rngCopy = Union(.Columns("A"), .Columns("D:F"), .Columns("H"))
    'filtered rows, not including header row - assumes row 1 is headers
    Set rngCopy = Intersect(rngCopy, .Range("A1:H" & lRow), .Range("A1:H" & lRow).Offset(1)).SpecialCells(xlCellTypeVisible)

    rngCopy.Copy

End With

wsShip.Range("B4").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False


End Sub

Upvotes: 1

Karthick Gunasekaran
Karthick Gunasekaran

Reputation: 2713

try the below code

Sub runthiscode()
    Worksheets("Efficiency").Select
    lastrow = Range("A" & Rows.Count).End(xlUp).Row
    startingrow = 4
    For i = 2 To lastrow
        If Cells(i, 2) = "Shipped" Then
            cella = Cells(i, 1)
            celld = Cells(i, 4)
            celle = Cells(i, 5)
            cellf = Cells(i, 6)
            cellh = Cells(i, 8)
            Worksheets("Ship").Cells(startingrow, 2) = cella
            Worksheets("Ship").Cells(startingrow, 5) = celld
            Worksheets("Ship").Cells(startingrow, 6) = celle
            Worksheets("Ship").Cells(startingrow, 7) = cellf
            Worksheets("Ship").Cells(startingrow, 9) = cellh
            startingrow = startingrow + 1
        End If
    Next i
End Sub

Upvotes: 0

Related Questions