VBA: Satırları Seçmek için Ölçütleri Kullanarak (Kopyala/Yapıştır) Bir Tablo Oluşturun, Sonra Sütunları Belirtin

Question

Başka bir Excel sayfasından "Verimlilik" sayfaından veri alarak bir Excel Sayfası "Gemisi" üzerinde bir tablo oluşturmak istiyorum. "Verimlilik" sayfasındaki satır verileri "Gönderildi", "Çık", "İçe Aktar" ve "Dışa Aktar" ile kategorilere ayrılır. Her kategori (sevk, bırak, içe aktarma, dışa aktarma) birkaç öğeye sahiptir ve bunlar belirli bir sırada değildir. "Verimlilik" sayfasındaki tablo A: H sütunlarını kaplar ve 2. sıradan başlar; uzunluk değişebilir. "Gönderilen" için satırları aramak ve eşleşen satırların A, D: F ve H sütunlarını kopyalayıp "Gemi" sayfasının B4 hücresine yapıştırarak yapıştırmak istiyorum. Biri bana yardım edebilir mi lütfen?

Sub Gemi()

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

senin soruda belirtilen Bu kod bilgilere dayanarak test edilmiştir

Answer 1

:

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 

Answer 2

aşağıdaki kodu deneyin

VLOOKUP veya OFFSET kullanarak

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