在列中循环插入工作表名称 - 不匹配错误

问题描述

尝试执行以下操作

1- 打开包含多个工作簿（Origins）的目录，复制/粘贴 每个工作表进入主工作簿（Destin）

2- 在主工作表 (Destin) 的“A”列中插入来自 dir (Origin) 的每个工作表的名称 - 工作表名称包含日期

3- 最后，通过复制/粘贴每个工作表将主工作簿（Destin）中的所有工作表合并到“摘要”表中 另一个下面的工作表（即数据库格式）

让第 1 步工作......现在卡住了（第 2 步不匹配错误）

Option Explicit

Sub AllFiles()

'Application.EnableCancelKey = xldisabled
Application.displayAlerts = True
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 lastrow As Long

    
' set master workbook
Set Masterwb = Workbooks("masterbook_AAFC.xlsm")
folderPath = "C:\Users\axchilmeran.G3NETWORK\Downloads\Master_AAFC\" 'contains folder path

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

    Filename = Dir(folderPath & "*.csv*")

        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,".pdf.csv","")
                
                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("B" & PasteRow).PasteSpecial xlPasteValues
    

下面这两行给了我不匹配错误！

    **lastrow = NewSht.UsedRange.Rows(NewSht.UsedRange.Rows.Count).Row
    Worksheets(NewSht).Range("A2:A" & lastrow).Value = NewSht.Name**
        
        
    Next sh
    
    wb.Application.CutcopyMode = False
    wb.Close False

Exit_Loop:
    Set wb = nothing
    Filename = Dir
Loop

Application.ScreenUpdating = True
Application.displayAlerts = True

End Sub

解决方法

暂无找到可以解决该程序问题的有效方法，小编努力寻找整理中！

如果你已经找到好的解决方法，欢迎将解决方案带上本链接一起发送给小编。

小编邮箱:dio#foxmail.com (将#修改为@）