VBA循環遍歷每行並將相關數據複製到另一個工作簿

Question

我有一個稱爲master（工作表2）的工作簿。 這包含數據線，像這樣：

Week Company  item No  Weight 
2  A   1222   100g 
2  A   1234   100g 
2  A   2222   100g 
2  B   1111   100g 
2  C   555   100g 

我有一個名爲template.xlsx

我想通過我的主簿各環線模板文件。 將該公司複製到模板上的單元格C12中。 模板上的單元格A27的項目編號。 模板上單元格B27的權重。

這很簡單，並顯示在上圖中。

但是，如果公司A出現3次，那麼每個項目號和權重都需要複製到模板中 - 需要插入新行。

結果應該如下：

基本上我需要遍歷每行中我的主人的工作簿，表2，和每個相關列複製到我的模板工作簿相應的單元格。它需要做到這一點，但也可以將同一家公司分組到一個模板中，並根據需要將所有項目號列入新行（如公司A示例）。

這是我的代碼到目前爲止，很基本，但我是全新的vba，所以任何幫助將非常感激。

Sub foo2() 
Dim x As Workbook 
Dim y As Workbook 

'## Open both workbooks first: 
Set x = ThisWorkbook 
Set y = Workbooks("template.xlsx") 

'Now, transfer values from x to y: 
y.Sheets(1).Range("C12").Value = x.Sheets(2).Range("B2") 
y.Sheets(1).Range("A27").Value = x.Sheets(2).Range("C2") 

y.SaveAs ("C:\templates\" & Range("B2").Value & ".xlsx") 

'Close x: 
x.Close 

End Sub 

Answer 1

單元格可以包含多行信息。您可以將任意數量的項目放在單個單元格內的單獨行上，只要您喜歡。它可以防止添加新行，這通常很麻煩。您可以使用這樣的功能來跟蹤單個單元格中的多行。將其粘貼到一個模塊中，並多次運行sub testFunction。你會看到，它把許多數據線到由人權委員會界定的單電池（10）

Sub testfunction() 
Dim rnge As Range 

    Set rnge = Sheet1.Range("D1") 
    Run addLinesToSingleCell("Jack and Jill", rnge) 
End Sub 

Function addLinesToSingleCell(newText As Variant, rng As Range) 
    If rng.Value <> "" And InStr(1, rng.Value, Chr(10)) > 0 Then ' if cell is occupied 
      myArr = Split(rng.Value, Chr(10)) '  with multiple lines 
      myString = newText & Chr(10) ' this is the new data to add 
      For i = LBound(myArr) To UBound(myArr) 
       If i <> UBound(myArr) Then 
        myString = myString & myArr(i) & Chr(10) 
       Else 
        myString = myString & myArr(i) 
       End If 
      Next i 
      rng.Value = myString 
    Else 
     If rng.Value <> "" Then ' If cell is occupied by only one line 
      rng.Value = newText & Chr(10) & ActiveCell.Value 
     Else 
      rng.Value = newText ' Cell is empty 
     End If 
    End If 
End Function 

Answer 2

這個代碼過濾器B列，每家公司（如果公司已經更新，它會跳過），然後循環通過每家公司的條目，然後將它們保存到你將它們保存到路徑：

Sub foo2() 
Dim WB1, WB2, WB3 As Workbook 
Dim Cel, Rng As Range 
Dim i, a, iLastRow As Long 

Set WB1 = ThisWorkbook 
Set WB2 = Workbooks("template.xlsx") 
iLastRow = WB1.Sheets(2).Range("B" & Cells.Rows.Count).End(xlUp).Row 

i = 2 
Do Until i > iLastRow 
    If WorksheetFunction.CountIf(WB1.Sheets(2).Range("B1:B" & i - 1), Cells(i, 2).Value) > 0 Then GoTo Skip 
    WB1.Sheets(2).Range("$A$1:$D$" & Range("A1").CurrentRegion.Rows.Count).AutoFilter Field:=2, Criteria1:=Cells(i, 2).Value 
    Set Rng = Range("B2:B" & iLastRow).SpecialCells(xlCellTypeVisible) 
    WB2.SaveCopyAs ("C:\templates\" & WB1.Sheets(2).Cells(i, 2).Value & ".xlsx") 
    Set WB3 = Workbooks.Open("C:\templates\" & WB1.Sheets(2).Cells(i, 2).Value & ".xlsx") 
    For Each Cel In Rng 
     If a > 0 Then WB3.Sheets(1).Rows("27:27").Copy: WB3.Sheets(1).Rows(27 + a & ":" & 27 + a).Insert Shift:=xlDown: WB3.Sheets(1).Rows(27 + a & ":" & 27 + a).ClearContents: Application.CutCopyMode = False 
     WB3.Sheets(1).Range("A" & 27 + a).Value = WB1.Sheets(2).Cells(Cel.Row, 3).Value 
     WB3.Sheets(1).Range("B" & 27 + a).Value = WB1.Sheets(2).Cells(Cel.Row, 4).Value 
     a = a + 1 
nextSelection: 
    Next 
    WB3.Sheets(1).Range("C12").Value = Cel.Value 
    a = 0 
    WB1.Activate 
    Selection.AutoFilter 
    WB3.Close SaveChanges:=True 
    Set WB3 = Nothing 

Skip: 
    i = i + 1 
Loop 

WB2.Close SaveChanges:=False 
WB1.Close SaveChanges:=False 

End Sub