VBA循环遍历每行并将相关数据复制到另一个工作簿

我有一个工作簿称为主（表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。 你会发现它将许多行数据放入一个由Chr（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进行筛选（如果公司已更新，则跳过），然后遍历每个公司的条目，然后将它们保存到您将它们保存到的path中：

 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