Question

在开始解释我的问题之前，对于凌乱的代码感到抱歉，我仍然是VBA的初学者，并提前感谢您的帮助。

所以我试图做的是将文件夹中某些工作簿的内容复制到我的主文件中，这有点像数据库。这里的诀窍是我需要将文件中的2张纸复制到我的主文件的第一张纸上。

同时，通过很多帖子，像这样的帖子， VBA Loop through files in folder and copy/paste to master file，我想出了这段代码：

Option Explicit

Sub AllFiles()

Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.EnableEvents = False
Application.EnableCancelKey = xlDisabled
Application.ScreenUpdating = False

Dim folderPath As String
Dim Filename As String
Dim wb As Workbook
Dim Masterwb  As Workbook
Dim sh As Worksheet
Dim NewSht As Worksheet
Dim FindRng As Range
Dim PasteRow As Long
Dim i As Integer

' set master workbook
Set Masterwb = ThisWorkbook



folderPath = Sheets("teste").Range("A1").Value 'contains folder path

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

For i = 1 To Sheets("leit_func").Range("S2")
Filename = Dir(folderPath & Sheets("teste").Range("A3"))

Do While Filename <> ""
    Set wb = Workbooks.Open(folderPath & Filename)

    If Len(wb.Name) > 35 Then
        MsgBox "Sheet's name can be up to 31 characters long, shorten the Excel file name"
        wb.Close False
        GoTo Exit_Loop
    Else
        ' add a new sheet with the file's name (remove the extension)
        '-------------------------------------------------------------------------------------------
        'Set NewSht = Masterwb.Worksheets.Add(After:=Masterwb.Worksheets(1))
        'NewSht.Name = Replace(wb.Name, ".xlsx", "")
        '-------------------------------------------------------------------------------------------

    Set NewSht = ThisWorkbook.Sheets(i)



    End If

    ' loop through all sheets in opened wb

    For Each sh In wb.Worksheets

        ' get the first empty row in the new sheet
        Set FindRng = NewSht.Cells.Find(What:="*", Lookat:=xlPart, LookIn:=xlFormulas, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False)
        If Not FindRng Is Nothing Then ' If find is successful
            PasteRow = FindRng.Row + 1
        Else ' find was unsuccessfull > new empty sheet, should paste at the first row
            PasteRow = 1
        End If
        sh.UsedRange.Copy
        NewSht.Range("A" & PasteRow).PasteSpecial xlPasteValues
        'NewSht.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:=xlNone, SkipBlanks:= _
                False, Transpose:=False

    Next sh
    wb.Close False
Exit_Loop:
    Set wb = Nothing
    Filename = Dir()
Loop

 Next i


Application.ScreenUpdating = True
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.EnableEvents = False
End Sub

使用此代码我可以将信息粘贴到不同的工作表中，但问题是它从文件夹中的所有文件中获取内容，我想要第1页中的文件1，第2页中的文件2等等。

我认为我的问题与我的纸张周期的放置有关，但我并不完全确定。

谢谢！

Answer 1

这是我保留的脚本库的复制/粘贴。它是如何遍历目录中的文件并将每个工作表复制并粘贴到主工作簿中的新工作表的粗略示例。我已经包含了一个部分，其中显示了如何附加到范围的末尾。两者都很有用。请注意，我使用数组来更轻松，更快速地移动数据。

Public Sub this()
    Dim path As String, fileName As String, shtName As String
    Dim sheet As Worksheet, thisWB As Workbook, thatWB As Workbook
    Dim arr() As Variant
    Dim rowC As Long, colC As Long, mrowC As Long, mColC As Long
    path = "your path to directory" & "\"
    fileName = Dir(path & "*.xl??")
    Set thisWB = ThisWorkbook
    Do While Len(fileName) > 0
        Set thatWB = Workbooks.Open(path & fileName, True, True)
        For Each sheet In thatWB.Sheets
            shtName = Left(Mid(fileName, 1, InStrRev(fileName, ".") - 1), 30)
            thisWB.ActiveSheet.Name = shtName
            mrowC = thisWB.Sheets(shtName).UsedRange.Rows.Count
            mColC = thisWB.Sheets(shtName).UsedRange.Columns.Count
            arr = sheet.UsedRange
            rowC = sheet.UsedRange.Rows.Count
            colC = sheet.UsedRange.Columns.Count
            thisWB.Sheets(shtName).Range(thisWB.Sheets(shtName).Cells(mrowC + 1, 1), thisWB.Sheets(shtName).Cells(mrowC + 1 + rowC, colC)).Value2 = arr
        Next sheet
        thatWB.Close False
        fileName = Dir()
        thisWB.Sheets.Add After:=Worksheets(Worksheets.Count)
    Loop
End Sub

循环浏览文件夹中的文件，将内容复制到特定工作表并循环显示主文件

1 个答案: