嘗試在單獨的選項卡中創建包含特定資訊的檔案

我有多個檔案試圖合并到一個檔案中。

我成功地做到了，感謝一個善良的靈魂的幫助。但是，現在我必須將每個檔案中的資訊分成同一檔案內的單個選項卡。

下面的代碼從我 PC 上 x 位置的多個檔案中復制資訊，然后使用回圈將它們全部粘貼到一個選項卡上。粘貼資訊后，我正在嘗試在每個回圈中停止 VBA，然后創建一個新選項卡并粘貼資訊并輸入代碼等等。

Option Explicit

Sub Mergebytabs()

Dim wbk1 As Workbook
Set wbk1 = ThisWorkbook
Dim sFolderPath As String
sFolderPath = InputBox("Please introduce the path where files are stored", _
    "Select Files' Path", "Paste path here")
If Len(sFolderPath) = 0 Then Exit Sub
If Right(sFolderPath, 1) <> "\" Then sFolderPath = sFolderPath & "\"

Dim sFilename As String: sFilename = Dir(sFolderPath & "*.xls*")
If Len(sFilename) = 0 Then Exit Sub

Dim dwb As Workbook: Set dwb = Workbooks.Add(xlWBATWorksheet)
Dim dws As Worksheet: Set dws = dwb.Worksheets(1)
Dim dfCell As Range
Set dfCell = dws.Range("A1")

Dim swb As Workbook
Dim sws As Worksheet
Dim srg As Range
Dim sFilePath As String
Dim sCount As Long

Dim siteCount As Integer
Dim ilv As Integer
Dim var1 As Worksheet
    
     
Do While Len(sFilename) > 0
Sheets.Add after:=ActiveSheet
Sheets(sCount).Activate
Set swb = Workbooks.Open(sFolderPath & sFilename)
On Error Resume Next ' test if the worksheet exists
        Set sws = swb.Worksheets("Sheet1")
    On Error GoTo 0
    If Not sws Is Nothing Then ' worksheet exists
        sCount = sCount   1
        Set srg = sws.Range("A1").CurrentRegion
        srg.Copy dfCell
        Set dfCell = dfCell.Offset(srg.Rows.Count)
        Set sws = Nothing
        
        siteCount = 0
        For ilv = 1 To siteCount
        var1 = Sheets.Add(after:=Sheets(Worksheets.Count))
        var1.Name = "Sheet_Name_" & CStr(ilv)
        Next ilv
        
        'Else ' worksheet doesn't exist
    End If
    swb.Close SaveChanges:=False
    sFilename = Dir
Loop

uj5u.com熱心網友回復：

從每個檔案復制到單獨的作業表。

Sub MergeByTabs()

    Dim swb As Workbook, sws As Worksheet, srg As Range
    Dim dwb As Workbook, dws As Worksheet
    Dim n As Long, sFolderPath As String, sFilename As String
    
    ' select folder
    With Application.fileDialog(msoFileDialogFolderPicker)
        .InitialFileName = ThisWorkbook.Path
        .Title = "Select folder ."
        If .Show = False Then
            MsgBox "Folder not selected"
            Exit Sub
        End If
        sFolderPath = .SelectedItems(1)
    End With
    sFolderPath = sFolderPath & "\"
    
    ' create destination workbook with one sheet
    Set dwb = Workbooks.Add(xlWBATWorksheet)
    
    ' loop through files
    Application.ScreenUpdating = False
    sFilename = Dir(sFolderPath & "*.xls*")
    Do While sFilename <> ""
        
        ' open source workbook
        Set swb = Workbooks.Open(sFolderPath & sFilename, ReadOnly:=True)
        
        ' test if the worksheet exists
        On Error Resume Next
        Set sws = swb.Worksheets("Sheet1")
        On Error GoTo 0
    
        ' if sheet exists then copy data
        If Not sws Is Nothing Then
            
            ' create destination sheet if required
            n = n   1
            If n > dwb.Sheets.Count Then
                Set dws = dwb.Sheets.Add(after:=dwb.Sheets(dwb.Sheets.Count))
            Else
                Set dws = dwb.Sheets(n)
            End If
            dws.Name = "Sheet_Name_" & CStr(n)
            
            ' copy data
            Set srg = sws.Range("A1").CurrentRegion
            srg.Copy dws.Range("A1")
           
        End If
        swb.Close False
        
        ' next file
        sFilename = Dir
    Loop
    Application.ScreenUpdating = True
    
    MsgBox n & " files processed", vbInformation
 
End Sub

標籤：

上一篇：平均近距離GPS坐標

下一篇：如果整數為0或-1，如何停止VBA將整數函式引數解釋為布林值