vba - 在我的 Do while 循环中遇到问题

Question

VBA 新手，最初我的问题是将 CSV 文件中的文本复制到字符串中，然后最终复制到主工作簿。我使用了以下完美运行的代码：

Sub Compiler()

    Dim handle As Integer
    Dim wbDst As Workbook
    Dim wsDst As Worksheet
    Dim lLastRow As Long
    Dim MyPath As String
    Dim strFilename As String

    handle = FreeFile
    Set wbDst = ThisWorkbook
    Set wsDst = wbDst.Worksheets("First Sheet")
    lLastRow = wsDst.UsedRange.Rows(wsDst.UsedRange.Rows.Count).Row + 1

    Sheets("First Sheet").Columns(1).NumberFormat = "@"
    Sheets("First Sheet").Columns(2).NumberFormat = "@"
    Sheets("First Sheet").Columns(3).NumberFormat = "@"

    MyPath = "W:\Test Folder\"
    strFilename = Dir(MyPath, vbNormal)

    Do While strFilename <> ""
    Dim buffer As String
        Open MyPath & strFilename For Input As #handle
        buffer = Input(LOF(handle), handle)  '<-- reads the entire contents of the file to "buffer"
        Close #handle

        With CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
            .SetText buffer
            .PutInClipboard
        End With

        wsDst.Paste wsDst.Range("A" & lLastRow)

        'Application.CutCopyMode = False
        strFilename = Dir()
    Loop

End Sub

但是，由于某种原因，它只复制粘贴了一些文件而不是其他文件（或者它可能会覆盖它？重点是一些文件没有被复制进去）。不知道为什么会这样？是因为文件中有一些空白单元格吗？为了纠正这个问题，我用 0 替换了所有空白单元格 - 没有用。是因为复制粘贴区域不同吗？如果是这种情况，不知道如何纠正

因此，经过长时间的调查，我发现了一种不切实际的方法，如果您粘贴需要一个一个复制的文件，它可以解决问题，但效率低下。因此，对于临时解决方案，我执行了以下操作，其中 vba 代码将文件中的文件从临时文件夹复制到源文件夹，完成复制粘贴到主工作簿的工作，然后删除复制的文件。对于某些人原因，即使它是一个 Do while 循环，代码也会在第一个停止。不确定这里有什么问题以及这里最有效的方法是什么？

Sub ISINCompiler()

    'Declare Variables
    Dim FSO
    Dim MyPath As String
    Dim strFilename As String
    Dim sFile As String
    Dim sSFolder As String
    Dim sDFolder As String

    Application.DisplayAlerts = False

    MyPath = "C:\Users\Tomhardy\Desktop\ISIN-Compiler Temp\"
    strFilename = Dir(MyPath, vbNormal)

    'This is Your File Name which you want to Copy
    'Change to match the destination folder path
    sDFolder = "W:\Test Folder\"

    'Create Object
    Set FSO = CreateObject("Scripting.FileSystemObject")

    'Checking If File Is Located in the Source Folder
    Do While strFilename <> ""
        If Not FSO.FileExists(MyPath & strFilename) Then
            MsgBox "Specified File Not Found", vbInformation, "Not Found"

            'Copying If the Same File is Not Located in the Destination Folder
        ElseIf Not FSO.FileExists(sDFolder & strFilename) Then
            FSO.CopyFile (MyPath & strFilename), sDFolder, True
            ISINCompilerx2  '<-Copying and pasting in text
            DeleteExample1 '<-Deleting the file after it has been copied in

        Else
            MsgBox "Specified File Already Exists In The Destination Folder", 
            vbExclamation, "File Already Exists"
        End If

        strFilename = Dir()
    Loop

End Sub


Private Sub ISINCompilerx2()

    Dim handle As Integer
    Dim wbDst As Workbook
    Dim wsDst As Worksheet
    Dim lLastRow As Long
    Dim someotherpath As String
    Dim somestrFilename As String

    handle = FreeFile
    Set wbDst = ThisWorkbook
    Set wsDst = wbDst.Worksheets("First Sheet")
    lLastRow = wsDst.UsedRange.Rows(wsDst.UsedRange.Rows.Count).Row + 1

    Sheets("First Sheet").Columns(1).NumberFormat = "@"
    Sheets("First Sheet").Columns(2).NumberFormat = "@"
    Sheets("First Sheet").Columns(3).NumberFormat = "@"

    someotherpath = "W:\Test Folder\"
    somestrFilename = Dir(someotherpath, vbNormal)

    Do While somestrFilename <> ""
        Dim buffer As String
        Open someotherpath & somestrFilename For Input As #handle
        buffer = Input(LOF(handle), handle)  '<-- reads the entire 
        contents of the file to "buffer"
        Close #handle

        With CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
            .SetText buffer
            .PutInClipboard
        End With

        wsDst.Paste wsDst.Range("A" & lLastRow)
        Application.CutCopyMode = False
        somestrFilename = Dir()

    Loop

End Sub

Private Sub DeleteExample1()

    On Error Resume Next
    Kill "W:\Test Folder\*.*"
    On Error GoTo 0

End Sub

新代码：

Sub ISINCompiler()
'Declare Variables
 Dim FSO As Object
 Dim MyPath As String
 Dim strFilename As String
Dim f As Object
Dim sDFolder As String
 Application.DisplayAlerts = False
MyPath = "C:\Users\Tomhardy\Desktop\ISIN-Compiler Temp\"
strFilename = Dir(MyPath, vbNormal)
 'This is Your File Name which you want to Copy
'Change to match the destination folder path
 sDFolder = "W:\Destination folder\"
  '     Create Object
  Set FSO = CreateObject("Scripting.FileSystemObject")
'Checking If File Is Located in the Source Folder
  For Each f In FSO.GetFolder(MyPath).Files
  If Not FSO.FileExists(MyPath & strFilename) Then
 MsgBox "Specified File Not Found", vbInformation, "Not Found"

'Copying If the Same File is Not Located in the Destination Folder
ElseIf Not FSO.FileExists(sDFolder & strFilename) Then
  FSO.CopyFile (MyPath & strFilename), sDFolder, True
'ISINCompilerx2
 'DeleteExample1
   MsgBox "Specified File Copied Successfully", vbInformation, "Done!"
  Else
  MsgBox "Specified File Already Exists In The Destination Folder", 
  vbExclamation, "File Already Exists"
End If
Next f
Set f = Nothing
Set FSO = Nothing
End Sub

标签： vbaexcel

Answer 1

您可以简化代码；

Dim Filename As String
Dim lLastRow As Long
Dim wsDst As Worksheet

Set wsDst = ThisWorkbook.Worksheets("First Sheet")
Filename = Dir("W:\Test Folder\*.csv")

    Do While Filename <> ""
        Set wbSrce = Workbooks.Open(Filename)
        lLastRow = wsDst.UsedRange.Rows.Count + 1
            wbSrce.Sheets(1).UsedRange.Copy wsDst.Range("A" & lLastRow)
            wbSrce.Close savechanges:=False
        Filename = Dir
    Loop