从文件夹中的多个Excel文件中复制 "S "列中的值，然后粘贴到特殊文件中。

Question

我想浏览一个文件夹，读取第一个Excel文件，并复制列中的数据。S 并将其粘贴到另一个工作簿中，然后读取第二个文件，并在上一粘贴的最后一行后粘贴数值，依此类推。

我的代码是

    '''
    Public MyFolder As String
    Public MyFile As String
    Public eRow As Long
    Dim xl As New Excel.Application
    With 
 xl.FileDialog(Microsoft.Office.Core.MsoFileDialogType.msoFileDialogFolderPicker)
        .AllowMultiSelect = False
        .Show()
        MyFolder = .SelectedItems(1) & "\"
        Err.Clear()
    End With
    MyFile = Dir(MyFolder & "\*.xls*", FileAttribute.ReadOnly)
    Dim BBSVal As String
    Dim Lastrow As Long
    BBSVal = cboBBS.Text
    Do While Len(MyFile) > 0
        xl.Workbooks.Open(Filename:=MyFolder & "\" & MyFile, UpdateLinks:=False)
        Lastrow = xl.ActiveSheet.UsedRange.Rows.Count
        xl.ActiveSheet.Range("S1", "S" & Lastrow).Copy()
        xl.ActiveWorkbook.Close(SaveChanges:=vbTrue)
        eRow = xl.Worksheets("BBSName").Cells(xl.Rows.Count, 1).End(Excel.XlDirection.xlUp).Offset(1, 0).Row
        xl.Worksheets("BBSName").Range("A" & eRow.ToString).PasteSpecial()
    Loop
    MyFile = Dir(MyFolder)
'''

代码运行无误，但在指定的文件中没有完成粘贴？非常感谢您的帮助

谢谢，祝愿Moheb Labib

Answer 1

     Sub CopyData(ToFile As String, ToSheet As String, ToCol As String, FromFolder As String, FromSheet As String, FromCol As String)
        Dim Xl As New Microsoft.Office.Interop.Excel.Application
        Dim dWorkBook As Workbook
        Try
            Xl.Workbooks.Open(ToFile)
            dWorkBook = Xl.Workbooks(FileIO.FileSystem.GetName(ToFile))
        Catch ex As Exception
            MessageBox.Show(ex.Message & vbCrLf & "file not found or bad format or access error")
            Xl.Application.Quit()
            Xl.Quit()
            Exit Sub
        End Try
        Dim dSheet As Worksheet
        Try
            dSheet = dWorkBook.Sheets(ToSheet)
        Catch ex As Exception
            MessageBox.Show(ex.Message & vbCrLf & "sheet not found or bad name 'ToSheet'")
            Xl.Application.Quit()
            Xl.Quit()
            Exit Sub
        End Try
        If IO.Directory.Exists(FromFolder) = False Then
            MessageBox.Show("Bad path 'FromFolder'" & vbCrLf & FromFolder)
            Xl.Application.Quit()
            Xl.Quit()
            Exit Sub
        End If
        Dim sfiles As String() = IO.Directory.GetFiles(FromFolder, "*.xlsx", SearchOption.TopDirectoryOnly)
        If sfiles.Count = 0 Then
            MessageBox.Show("no excel files '*.xlsx' in directory 'FromFolder'" & vbCrLf & FromFolder)
            Xl.Quit()
            Exit Sub
        End If

        Dim ErrMsg As String = "Error list" & vbCrLf
        Dim faild As Integer = 0
        For Each X As String In sfiles
            Dim tmpWorkBook As _Workbook
            Try
                Xl.Workbooks.Open(X)
                tmpWorkBook = Xl.Workbooks(FileIO.FileSystem.GetName(X))
            Catch ex As Exception
                ErrMsg &= "bad format or access error " & X & vbCrLf
                faild += 1
                GoTo 1
            End Try
            Dim tmpSheet As _Worksheet
            Try
                tmpSheet = tmpWorkBook.Sheets(FromSheet)
            Catch ex As Exception
                ErrMsg &= "sheet not found or bad name  File: " & X & vbCrLf
                faild += 1
                tmpWorkBook.Close()
                GoTo 1
            End Try

            Dim ToRange As Range = dSheet.Range(ToCol & dSheet.Rows.Count).End(XlDirection.xlUp).Offset(1, 0)

            Dim FromRange As Range = tmpSheet.Range(FromCol & "1").End(XlDirection.xlDown)
            Dim tmpAddress As String = FromRange.Address
            FromRange = FromRange.End(XlDirection.xlDown)
            tmpAddress &= ":" & FromRange.Address
            If tmpAddress.EndsWith("1048576") Then
                ErrMsg &= "Column is empty :[ " & FromCol & " ]    File: " & X & vbCrLf
                tmpWorkBook.Close()
                faild += 1
                GoTo 1
            End If
            FromRange = tmpSheet.Range(tmpAddress)
            FromRange.Copy(ToRange)

            tmpWorkBook.Close()

1:
        Next


        dWorkBook.Close(True)
        Xl.Application.Quit()
        Xl.Quit()
        If ErrMsg.Length < 13 Then ErrMsg &= "No Errors" & vbCrLf
        ErrMsg = "Success :" & sfiles.Count - faild & vbCrLf & "Failed :" & faild & vbCrLf & vbCrLf & ErrMsg
        MessageBox.Show(ErrMsg)
    End Sub

使用方法

这将复制数据 从 源表A列 到 Sheet1列S

CopyData("c:\test.xlsx", "Sheet1", "S", "D:\folder", "sourceSheet", "A")