Question

我创建了一个工具，下面的宏将所有.csv文件复制到Excel工作表中。我希望将数据复制到我创建的“Consol.xlsx”文件中。当前代码复制工具中的数据而不是“Consol.xlsx”文件。我无法更新代码，以便正确复制数据。

以下是我的代码：

Sub Button_click2()
Call AddNew
Call ImportCSVsWithReference
End Sub

Sub AddNew()
Application.DisplayAlerts = False
    Dim thisWb As Workbook
    Set thisWb = ActiveWorkbook
    Workbooks.Add
    ActiveWorkbook.SaveAs Filename:=thisWb.path & "\Consol.xlsx"
Application.DisplayAlerts = True
End Sub


Sub ImportCSV()

   Dim strSourcePath As String
   Dim strDestPath As String
   Dim strFile As String
   Dim strData As String
   Dim x As Variant
   Dim Cnt As Long
   Dim r As Long
   Dim c As Long

   Application.ScreenUpdating = False

   'Change the path to the source folder accordingly
   strSourcePath = Application.ActiveWorkbook.path

   If Right(strSourcePath, 1) <> "\" Then strSourcePath = strSourcePath & "\"

   'Change the path to the destination folder accordingly
   strDestPath = Application.ActiveWorkbook.path

   If Right(strDestPath, 1) <> "\" Then strDestPath = strDestPath & "\"

   strFile = Dir(strSourcePath & "*.csv")

   Do While Len(strFile) > 0
       Cnt = Cnt + 1
       r = Cells(Rows.count, "A").End(xlUp).Row + 1
       Open strSourcePath & strFile For Input As #1
           Do Until EOF(1)
               Line Input #1, strData
               x = Split(strData, ",")
               For c = 0 To UBound(x)
                   Cells(r, c + 1).Value = Trim(x(c))
               Next c
               r = r + 1
           Loop
       Close #1
       Name strSourcePath & strFile As strDestPath & strFile
       strFile = Dir
   Loop

   Application.ScreenUpdating = True

   If Cnt = 0 Then _
       MsgBox "No CSV files were found...", vbExclamation

End Sub

Answer 1

看起来你有两件作品。您的第一个子例程会保存名为consol.xlsx的空白工作簿。

然后，您的第二个子例程遍历目录，打开每个csv文件，并将其应对到某些未指定的范围。

我在循环之前插入的内容是：

Set wbkConsol = Workbooks.Open(thisWorkbook.path & "\Consol.xlsx")

然后，在循环CSV文件期间：

strFile = Dir(strSourcePath & "*.csv")
Do While Len(strFile) > 0
   Cnt = Cnt + 1
   r = Cells(Rows.count, "A").End(xlUp).Row + 1
   Open strSourcePath & strFile For Input As #1
       Do Until EOF(1)
           Line Input #1, strData
           ' Set wshAdd = wbkConsol.Worksheets.Add() ' New ws in wbk
           ' wshAdd.Name = left(strFile, 31) ' First 31-chars of filename.
           x = Split(strData, ",")
           For c = 0 To UBound(x)
               wshAdd.Cells(r, c + 1).Value = Trim(x(c))
           Next c
           r = r + 1
       Loop
   Close #1
   Name strSourcePath & strFile As strDestPath & strFile
   strFile = Dir()
Loop

作为补充说明：您可以通过引用将工作簿从第一个子文件传递到第二个子文件。这样，你就不必再打开它了。这可以通过将按钮单击组合到一个命令中来实现。

Sub1()
      wbkConsol = workbooks.Add
      Call sub2(wbkConsol)
End sub

输出在不同的工作簿中

1 个答案: