複製行

Question

在表2具有在列A中的一組規則

在實施例A列有每行中的多個代碼，根據對應於行B至H與數據該代碼。

在表1，我希望能夠以放置代碼之一，並且具有轉讓VBA行B：從表2 h如果此碼與一個在列A

這裏匹配時，該程序我有到目前爲止，它將行傳送過來，但不是正確的行。

Dim i As Integer 
    Dim x As Integer 
    Dim row As Integer 
    Dim oldRow As Integer 
    Dim found As Boolean 
    Dim ws1 As Worksheet 
    Dim ws2 As Worksheet 
    Set ws1 = Worksheets("Sheet1") 
    Set ws2 = Worksheets("Sheet2") 
    Dim rng As Range, cell As Range, rng2 As Range, cell2 As Range 

Set rng2 = ws2.Range("A1:A212") 
Set rng = ws1.Range("A1:A212") 

row = 1 
oldRow = 1 


For Each cell In rng 
    row = row + 1 

    For Each cell2 In rng2 
     oldRow = oldRow + 1 

     If cell.Value = cell2.Value Then 
     row = row - 1 
      ws1.Cells(row, 2) = ws2.Cells(oldRow, 2) 
      ws1.Cells(row, 3) = ws2.Cells(oldRow, 3) 
      ws1.Cells(row, 4) = ws2.Cells(oldRow, 4) 
      ws1.Cells(row, 5) = ws2.Cells(oldRow, 5) 
      ws1.Cells(row, 6) = ws2.Cells(oldRow, 6) 
      ws1.Cells(row, 7) = ws2.Cells(oldRow, 7) 
      ws1.Cells(row, 8) = ws2.Cells(oldRow, 8) 
      found = True 
     End If 



    Next 
    found = False 
    oldRow = 1 

Next 

End Sub 

謝謝幫助，謝謝。

Answer 1

我會改變這樣的代碼：

Sub test() 
    Dim i As Integer 
    Dim n As Integer 
    Dim ws1 As Worksheet 
    Dim ws2 As Worksheet 
    Set ws1 = Worksheets("Sheet1") 
    Set ws2 = Worksheets("Sheet2") 

    'Cycles through the codes in sheet 1 
    For i = 2 To ws1.Cells(ws1.Rows.Count, 1).End(xlUp).row Step 1 
     For n = 2 To ws2.Cells(ws2.Rows.Count, 1).End(xlUp).row Step 1 
      If ws1.Cells(i, 1).Value = ws2.Cells(n, 1).Value Then 
       ws1.Cells(i, 2).Value = ws2.Cells(n, 2).Value 
       ws1.Cells(i, 3).Value = ws2.Cells(n, 3).Value 
       ws1.Cells(i, 4).Value = ws2.Cells(n, 4).Value 
       ws1.Cells(i, 5).Value = ws2.Cells(n, 5).Value 
       ws1.Cells(i, 6).Value = ws2.Cells(n, 6).Value 
       ws1.Cells(i, 7).Value = ws2.Cells(n, 7).Value 
       ws1.Cells(i, 8).Value = ws2.Cells(n, 8).Value 
      End If 
     Next n 
    Next i 
End Sub 

Answer 2

未經測試：

Dim ws1 As Worksheet 
Dim ws2 As Worksheet 
Dim rng As Range, f As Range, rng2 As Range 
Dim c as range, cell as Range 


Set ws1 = Worksheets("Sheet1") 
Set ws2 = Worksheets("Sheet2") 
Set rng = ws1.Range("A1:A212") 
Set rng2 = ws2.Range("A1:A212") 

row = 1 
oldRow = 1 


For Each cell In rng.Cells 
    if len(cell.value)>0 Then 
     Set f = rng2.Find(cell.Value, lookin:=xlvalues, lookat:=xlWhole) 
     if not f is nothing then 
      cell.offset(0,1).Resize(1,7).Value = _ 
       f.offset(0,1).resize(1,7).Value 
     end if 
    end if 
Next cell 

Answer 3

這是否需要在VBA？或者您是否可以使用VLOOKUP工作表功能？因爲這實際上是你試圖從事物的聲音中實現的。

您也可以通過使用VBA VLOOKUPApplication.WorksheetFunction.VLookup

你的問題可能是因爲您在循環的開始，而不是在最後..所以它運行它們的值在第一時間遞增row和oldRow將是2而不是1.你也可能不需要做row = row - 1，因爲它令人困惑。

Answer 4

你可以做到這一點將公式。在「工作表Sheet1」格B1，複製和向下：

=IF(COUNTIF(Sheet2!$A:$A,$A1)=0,"",VLOOKUP($A1,Sheet2!$A:$H,COLUMN(B1),0)) 

如果它必須是一個宏，這樣的事情應該爲你工作：

Sub tgr() 

    Dim ws1 As Worksheet 
    Dim ws2 As Worksheet 
    Dim rngFound As Range 
    Dim arrCodes As Variant 
    Dim arrResults As Variant 
    Dim varCode As Variant 
    Dim ResultIndex As Long 
    Dim cIndex As Long 

    Set ws1 = ActiveWorkbook.Sheets("Sheet1") 
    Set ws2 = ActiveWorkbook.Sheets("Sheet2") 

    arrCodes = ws1.Range("A1", ws1.Cells(Rows.Count, "A").End(xlUp)).Value 
    If Not IsArray(arrCodes) Then Exit Sub 'No data 
    ReDim arrResults(1 To UBound(arrCodes, 1), 1 To 7) 

    For Each varCode In arrCodes 
     ResultIndex = ResultIndex + 1 
     Set rngFound = ws2.Columns("A").Find(varCode, , xlValues, xlWhole) 
     If Not rngFound Is Nothing Then 
      For cIndex = 1 To UBound(arrResults, 2) 
       arrResults(ResultIndex, cIndex) = WorksheetFunction.VLookup(varCode, ws2.Range("A:H"), cIndex + 1, False) 
      Next cIndex 
     End If 
    Next varCode 

    ws1.Range("B1").Resize(UBound(arrResults, 1), UBound(arrResults, 2)).Value = arrResults 

End Sub