Question

我正在尝试编写一些代码，用于复制来自位置C24, C25的所有.xls文件中的单元格D24, D25和"C:\MyPath\"，而我刚开始使用VBA但是我在网上寻找一些解决方案，并能够编写一些代码，将所有excel文件组合在一个文件夹中，并将其复制到单个工作簿，每个工作簿都会进入每个工作表。

我工作的代码是

Option Explicit
Sub CopyWorksheets()

  Const sPath = "C:\MyPath\"
  Dim sFile As String
  Dim wbkSource As Workbook
  Dim wSource As Worksheet
  Dim wbkTarget As Workbook

  On Error GoTo ErrHandler
  Application.ScreenUpdating = False

  Set wbkTarget = ActiveWorkbook
  sFile = Dir(sPath & "*.xls*")
  Do While Not sFile = ""
    Set wbkSource = Workbooks.Open(Filename:=sPath & sFile, AddToMRU:=False)
    For Each wSource In wbkSource.Worksheets
      With wbkTarget
        wSource.Copy After:=.Sheets(.Sheets.Count)
      End With
    Next
    wbkSource.Close SaveChanges:=False
    sFile = Dir
  Loop

ExitHandler:
  Application.ScreenUpdating = True
  Exit Sub

ErrHandler:
  MsgBox Err.Description, vbExclamation
  Resume ExitHandler
End Sub

我是否可以了解上述代码的更改或补充以获得我的解决方案？

Answer 1

我将您的代码复制到新工作簿中。我将工作表Sheet1重命名为C24D25并创建了一个标题行：

listChoiceWidget
  :: forall t m. MonadWidget t m
  => Dynamic t [String]
  -> m (Event t Int)
listChoiceWidget choices = el "div" $ do
  asMap <- mapDyn (Map.fromList . zip [(0::Int)..]) choices
  evs :: Dynamic t (Map.Map Int (Event t ())) <- listWithKey asMap (\_ s -> dynButton s)
  dynEv :: Dynamic t (Event t Int) <- mapDyn (leftmost . Map.elems . Map.mapWithKey (\k e -> fmap (const k) e)) evs
  return $ switch (current dynEv)

在您的例程的顶部，我添加了我需要的额外变量和常量：

        A        B         C      D      E      F
  1 Workbook  Worksheet  C24    D24    C25    D25

将“C24D25”替换为您收集值的工作表的名称。

我将Const colTgtWbk As Long = 1 Const colTgtWsht As Long = 2 Const colTgtC24 As Long = 3 Const colTgtC25 As Long = 5 Dim wshtTarget As Worksheet Dim rowTgtCrnt As Long Set wshtTarget = ActiveWorkbook.Worksheets("C24D25") rowTgtCrnt = 2的定义修改为包含多个工作簿的笔记本电脑上的文件夹。

在我的代码顶部附近，我注释掉了：

sPath

接近结束时我评论道：

'On Error GoTo ErrHandler

我从不在开发过程中包含自己的错误处理程序，除非我在开发过程中发现需要，否则我从不在生产宏中包含错误处理程序。错误处理程序例程不是处理您期望并可以测试的错误的最佳方法。它们应该保留给您无法测试的错误，例如尝试打开您可能没有读取权限的文件。

围绕你的主要街区：

'ExitHandler:
  'Exit Sub
'ErrHandler:
  'MsgBox Err.Description, vbExclamation
  'Resume ExitHandler

我添加了一个If：

  Set wbkSource = Workbooks.Open(Filename:=sPath & sFile, AddToMRU:=False)
     to
   wbkSource.Close SaveChanges:=False

这可以避免尝试重新打开正在收集数据的工作簿。

我删除了：

 If sFile <> wbkTarget.Name Then

 End If

并将此代码替换为：

With wbkTarget
  wSource.Copy After:=.Sheets(.Sheets.Count)
 End With

这是在工作表C24D25中构建行的代码。

在底部我添加了：

With wshtTarget
  .Cells(rowTgtCrnt, colTgtWbk).Value = wbkSource.Name
  .Cells(rowTgtCrnt, colTgtWsht).Value = wSource.Name
  wSource.Range("C24:D24").Copy Destination:=.Cells(rowTgtCrnt, colTgtC24)
  wSource.Range("C25:D25").Copy Destination:=.Cells(rowTgtCrnt, colTgtC25)
  rowTgtCrnt = rowTgtCrnt + 1
End With

这会将列扩展为找到的数据的宽度。

以上更改的结果是：

wshtTarget.Columns.AutoFit

我希望我所做的改变的目的是显而易见的，如有必要，可以提出问题。

将单元格从2个或更多工作簿复制到新工作簿

1 个答案: