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