将单元格从一个表格复制到多个表格中Excel - VBA

Question

我在工作簿中的一个工作表中有数据。我想在另一本书中的多张纸上分发它。怎么做，这是图。

目前我使用下面的代码，但它不工作实在是太想的方式。这只是我的一个起点。

Dim row1, row2 
Dim i As Integer 
Dim cell1 As String 

' this is just an example where I am trying to loop through 3 cells but it does not work 
' the cells in my example are in G14,G15 and G16 


Dim wbk1 As Workbook, wbk2 As Workbook 

strFirstFile = "c:\Book1.xls" 
strSecondFile = "c:\Book2.xls" 
Set wbk1 = Workbooks.Open(strFirstFile) 
Set wbk2 = Workbooks.Open(strSecondFile) 
For i = 14 To 16 
    With wbk1.Sheets("Data") 
     Cells(i, 7).Copy 
    End With 

    With wbk2.Sheets("MyData") 
     Cells(i, 5).PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _ 
     False, Transpose:=False 
    End With 
Next i 

在我的例子，实际映射是这样

Book1.xls   Book2.xls 
sheet1->B3  -> Company->A3 
sheet1->C3  -> Address->C3 
sheet1->E3  -> Popularity->D3 

如果我能做到这一点，我的实际项目几乎是相同的。

Answer 1

该解决方案已根据修订后的问题进行了持续改写。

此解决方案假定宏SplitSheet位于其自己的工作簿中。它需要两个文件名，其硬编码为Source.xls和Dest.xls在这个版本中。此版本假定所有三个工作簿都位于或将位于同一文件夹中。在运行宏之前，源工作簿必须存在。目标工作簿不能存在。

该问题有四列，但真正的问题有六十。该解决方案旨在调整尺寸为Sheet1（也是硬编码）。哪些列将被移动，在哪里以及如何命名由三个数组控制，可以从他们当前的三个条目中放大。代码使用这些数组的实际大小。

我希望每一个困难的陈述都有充分的解释。祝你好运。

Sub SplitSheet() 

    Dim ColDestCrnt As Integer 
    Dim ColMapName() As Variant 
    Dim ColMapDest() As Variant 
    Dim ColMapSource() As Variant 
    Dim ColSourceCrnt As Integer 
    Dim ColSourceMax As Integer 
    Dim ColWidth() As Single 
    Dim DataCol() As Variant 
    Dim DataWSheet() As Variant 
    Dim FileNameSource As String 
    Dim FileNameDest As String 
    Dim InxColMap As Integer 
    Dim InxWSheet As Integer 
    Dim Path As String 
    Dim Rng As Range 
    Dim RowSourceCrnt As Integer 
    Dim RowSourceMax As Integer 
    Dim WBookDest As Workbook 
    Dim WBookSource As Workbook 

    ' These arrays define the mappings. Column B is to be copied to column A, 
    ' column C to C and column E to D. 
    ColMapSource = Array("B", "C", "E") 
    ColMapDest = Array("A", "C", "D") 
    ' The names to be given to the worksheets in the destination worksheet 
    ColMapName = Array("Company", "Address", "Popularity") 
    ' Additional entries may be added to these array providing they all have 
    ' the same number of entries. 

    If Workbooks.Count > 1 Then 
    ' It can get complicated if more than one workbook is open 
    ' at the start. I suggest aborting in this situation unless 
    ' there is an important reason for allowing it. 
    ' If this is a one-off transformation, use of Debug.Assert False, 
    ' which will stop execution until you press F5, is adequate if 
    ' unprofessional. If it is to be used repeatedly, you need a 
    ' proper error message for the user. 
    Debug.Assert False  ' execution error 
    Exit Sub 
    End If 

    ' This assumes all three workbooks will be in the same folder. 
    ' Change as necessary. 
    Path = ActiveWorkbook.Path 

    ' You must decide how to assign values to these variables 
    FileNameSource = "Source.xls" 
    FileNameDest = "Dest.xls" 

    If Dir$(Path & "\" & FileNameSource) = "" Then 
    ' Source workbook does not exist 
    Debug.Assert False  ' execution error 
    Exit Sub 
    End If 

    If Dir$(Path & "\" & FileNameDest) <> "" Then 
    ' Dest workbook exists 
    Debug.Assert False  ' execution error 
    Exit Sub 
    End If 

    Set WBookSource = Workbooks.Open(Path & "\" & FileNameSource) 

    With WBookSource 
    ' Replace "Sheet1" with the name of the source worksheet 
    With Sheets("Sheet1") 
     ' This determines the highest numbered row and the highest 
     ' number column in the source worksheet 
     Set Rng = .Range("A1").SpecialCells(xlCellTypeLastCell) 
     RowSourceMax = Rng.Row 
     ColSourceMax = Rng.Column 
     ' This copies the values of the entire source worksheet to array SourceWSheet 
     DataWSheet = .Range(.Cells(1, 1), .Cells(RowSourceMax, ColSourceMax)).Value 
     ' This saves the widths of the source columns 
     ReDim ColWidth(1 To ColSourceMax) 
     For ColSourceCrnt = 1 To ColSourceMax 
     ColWidth(ColSourceCrnt) = .Columns(ColSourceCrnt).ColumnWidth 
     Next 
    End With 
    ' We have no further need of the source workbook. Close without saving 
    .Close False 
    End With 
    Set WBookSource = Nothing 

    ' DataWSheet has dimensions (1 to RowSourceMax, 1 to ColSourceMax) 
    ' Normal practice is to have rows as the second dimension. This is not true 
    ' of array loaded from or to a worksheet. 

    Set WBookDest = Workbooks.Add 

    With WBookDest 
    ' The factory setting for Excel is to have three sheets 
    ' in a new workbook but that setting may be changed. 
    ' This Do Loop ensures there are enough sheets and that 
    ' any that are added are in sheet name sequence. 
    ' It does not delete any excess Sheets. 
    Do While UBound(ColMapName) > .Sheets.Count 
     .Sheets.Add After:=Sheets(.Sheets.Count) 
    Loop 
    ' Name the sheets with the values in ColMapName() and set the 
    ' width of the destination column to that of the source column. 
    ' The use of lbound (=lower bound) and ubound (=upper bound) 
    ' means this for-loop is controlled by the size of ColmapName. 
    ' Note one index is used for all three ColMap arrays because they match 
    For InxColMap = LBound(ColMapName) To UBound(ColMapName) 
     ' ColMapName has been loaded with Array. Its lower bound is almost 
     ' certainly zero but the documentation is not 100% clear that it will 
     ' always be zero. The lower bound for sheets is one. 
     ' "InxColMap + 1 - LBound(ColMapName)" performs the necessary adjustment 
     ' regardless of the ColMapName's lower bound 
     With .Sheets(InxColMap + 1 - LBound(ColMapName)) 
     .Name = ColMapName(InxColMap) 
     ' Convert the column letters in ColMapSource and ColMapDest 
     ' to numbers. Bit of a cheat but it works. 
     ColSourceCrnt = Range(ColMapSource(InxColMap) & "1").Column 
     ColDestCrnt = Range(ColMapDest(InxColMap) & "1").Column 
     .Columns(ColDestCrnt).ColumnWidth = ColWidth(ColSourceCrnt) 
     End With 
    Next 
    ' The destination worksheets are now prepared. 
    ' Size the array that will be used to copy data to the destination sheets 
    ReDim DataCol(1 To RowSourceMax, 1 To 1) 
    For InxColMap = LBound(ColMapSource) To UBound(ColMapSource) 
     ColSourceCrnt = Range(ColMapSource(InxColMap) & "1").Column 
     For RowSourceCrnt = 1 To RowSourceMax 
     DataCol(RowSourceCrnt, 1) = DataWSheet(RowSourceCrnt, ColSourceCrnt) 
     Next 
     With Sheets(ColMapName(InxColMap)) 
     ' Copy data to appropriate column in appropriate destination sheet 
     .Range(ColMapDest(InxColMap) & "1:" & _ 
        ColMapDest(InxColMap) & RowSourceMax).Value = DataCol 
     End With 
    Next 
    .SaveAs (Path & "\" & FileNameDest) 
    .Close False 
    End With 
    Set WBookDest = Nothing 

End Sub