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

我在工作簿的一页中有数据。我想在另一本书的多张纸上分发它。如何做到这一点，这里是图表

目前我正在使用下面的代码，但它的工作方式与假设的工作方式不同。这对我来说只是一个起点

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

---

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

根据修改后的问题，这个解决方案已被反复改写

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

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

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

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

子拆分页（）
Dim ColDestCrnt作为整数
Dim ColMapName（）作为变量
Dim ColMapDest（）作为变量
Dim ColMapSource（）作为变量
Dim COLSOURCRNT作为整数
Dim ColSourceMax作为整数
Dim ColWidth（）作为单个
Dim DataCol（）作为变量
Dim DataWSheet（）作为变量
Dim FileNameSource作为字符串
Dim FILENAME DEST作为字符串
Dim InxColMap为整数
作为整数的Dim InxWSheet
将路径设置为字符串
变暗Rng As范围
Dim ROWSOURCRNT作为整数
将RowSourceMax设置为整数
将WBookDest设置为工作簿
将WBookSource设置为工作簿
'这些数组定义映射。将B列复制到A列，
'C列到C列，E列到D列。
ColMapSource=数组（“B”、“C”、“E”）
ColMapDest=数组（“A”、“C”、“D”）
'目标工作表中工作表的名称
ColMapName=数组（“公司”、“地址”、“流行度”）
'如果所有条目都具有
'相同数量的条目。
如果工作簿.计数>1，则
'如果打开了多个工作簿，它可能会变得复杂
“一开始。我建议在这种情况下堕胎，除非
允许这样做有一个重要原因。
'如果这是一次性转换，请使用Debug.Assert False，
'在按下F5之前停止执行，如果
“不专业。如果要重复使用，您需要
'用户的正确错误消息。
Debug.Assert False“执行错误
出口接头
如果结束
'这假定所有三个工作簿都位于同一文件夹中。
"必要时改变。
Path=ActiveWorkbook.Path
'您必须决定如何为这些变量赋值
FileNameSource=“Source.xls”
FileNameDest=“Dest.xls”
如果Dir$（Path&“\”&FileNameSource）=“”，则
'源工作簿不存在
Debug.Assert False“执行错误
出口接头
如果结束
如果Dir$（Path&“\”&FileNameDest）”，则
'目标工作簿已存在
Debug.Assert False“执行错误
出口接头
如果结束
设置WBookSource=Workbooks.Open（路径&“\”&FileNameSource）
使用WBookSource
'将“Sheet1”替换为源工作表的名称
附页（“第1页”）
'这将确定编号最高的行和编号最高的行
“源工作表中的数字列”
设置Rng=.Range（“A1”）.SpecialCell（xlCellTypeLastCell）
RowSourceMax=Rng.Row
ColSourceMax=Rng.Column
'这会将整个源工作表的值复制到阵列SourceWSheet
数据表=.Range（.Cells（1，1），.Cells（RowSourceMax，ColSourceMax））.Value
'这将保存源列的宽度
ReDim ColWidth（1到ColSourceMax）
对于ColSourceCrnt=1到ColSourceMax
ColWidth（ColSourceCrnt）=.Columns（ColSourceCrnt）.ColumnWidth
下一个
以
'我们不再需要源工作簿。关闭而不保存
.关闭错误
以
设置WBookSource=Nothing
'数据表具有维度（1到RowSourceMax，1到ColSourceMax）
'通常的做法是将行作为第二维度。事实并非如此
'从工作表或加载到工作表的数组。
设置WBookDest=工作簿。添加
使用WBookDest
'Excel的出厂设置为有三张工作表
'但该设置可能会更改。
'此Do循环确保有足够的图纸
'任何添加的都是按图纸名称顺序添加的。
'它不会删除任何多余的工作表。
Do While UBound（ColMapName）>.Sheets.Count
.Sheets.Add After:=工作表（.Sheets.Count）
环
'使用ColMapName（）中的值命名工作表，并设置
'目标列的宽度与源列的宽度。
“使用lbound（=下限）和ubound（=上限）
'表示此for循环由ColmapName的大小控制。
'注意一个索引用于所有三个ColMap数组，因为它们匹配
对于InxColMap=LBound（ColMapName）到UBound（ColMapName）
'ColMapName已加载数组。它的下限几乎为零
“当然是零，但文件并不是100%清楚它是否会
“永远是零。图纸的下限为1。
“'InxColMap+1-LBound（ColMapName）”执行必要的调整
'而不考虑ColMapName的下限
带.Sheets（InxColMap+1-LBound（ColMapName））
.Name=ColMapName（InxColMap）
'转换ColMapSource和ColMapDest中的列字母
”他说。这有点骗人，但很管用。
ColSourceCrnt=范围（ColMapSource（InxColMap）和“1”）。列
ColDestCrnt=范围（ColMapDest（InxColMap）和“1”）列