将单元格从一张工作表复制到多张工作表 Excel - VBA

copy cells from one sheet into multiple sheets Excel - VBA

提问by Hammad Khan

I have data in one sheet in a workbook. I want to distribute it across multiple sheets in a another book. How to do it, here is the diagram.

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

Currently I am using the following code but it does not work the way it is suppose too. This is just a starting point for me.

目前我正在使用以下代码，但它也不能像假设的那样工作。这对我来说只是一个起点。

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

The actual mapping in my example is like this

我的例子中的实际映射是这样的

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

If I can achieve this, my actual project is almost the same.

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

回答by Tony Dallimore

This solution has been sustantially rewritten in light of the revised question.

根据修订后的问题，此解决方案已被彻底改写。

This solution assumes the macro SplitSheetis in its own workbook. Its needs two file names which are hard coded as Source.xlsand Dest.xlsin this version. This versions assumes all three workbooks are or will be in the same folder. The source workbook must exist before the macro is run. The destination workbook must not exist.

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

The question has four columns but the real problem has sixty. The solution is designed to resize to the dimensions of Sheet1(also hard coded). Which columns are to be moved, where to and how named are controlled by three arrays which can be enlarged from their current three entries. The code uses the actual size of these arrays.

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

I hope that every difficult statement is fully explained. Best of luck.

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

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