gpt4 book ai didi

vba - Excel,循环遍历 XLSM 文件并将行复制到另一张纸

转载 作者:行者123 更新时间:2023-12-04 19:51:19 27 4
gpt4 key购买 nike

我现在使用此代码遇到的主要问题是处理我打开的 xlsm 文件的错误。我对这些文件的 VB 代码没有编辑权限。如果 vb 出错,有没有办法跳过文件?

我有一个包含大约 99 个 xlsm 文件的文件夹,我希望遍历每个文件并复制让我们只说每个工作簿中的第 14 行并将其作为摘要粘贴到一个单独的工作簿中。到目前为止,这是我所拥有的;唯一的问题是它复制了一个空白行。当我单步执行 VB 时,我可以看到它不会在它打开的 xlsm 文件上运行宏。有人知道一些可以帮助我的代码吗?

 Sub MergeAllWorkbooks()
Dim SummarySheet As Worksheet
Dim FolderPath As String
Dim NRow As Long
Dim FileName As String
Dim WorkBk As Workbook
Dim SourceRange As Range
Dim DestRange As Range
Application.Calculation = xlCalculationAutomatic
' Create a new workbook and set a variable to the first sheet.
Set SummarySheet = Workbooks.Add(xlWBATWorksheet).Worksheets(1)

' Modify this folder path to point to the files you want to use.
FolderPath = "C:\Users\dredden2\Documents\SHAREPOINT ARCHIVING\PAGESETUP\TEST\"

' NRow keeps track of where to insert new rows in the destination workbook.
NRow = 2

' Call Dir the first time, pointing it to all Excel files in the folder path.
FileName = DIR(FolderPath & "*.xlsm")

' Loop until Dir returns an empty string.
Do While FileName <> ""
' Open a workbook in the folder
Set WorkBk = Workbooks.Open(FolderPath & FileName)
WorkBk.Application.EnableEvents = True
WorkBk.Application.DisplayAlerts = False
WorkBk.Application.Run _
"'" & FileName & "'!auto_open"
' Set the cell in column A to be the file name.
SummarySheet.Range("A" & NRow).Value = FileName

' Set the source range to be B14 through BF14.
' Modify this range for your workbooks.
' It can span multiple rows.
Set SourceRange = WorkBk.Sheets("Retrospective Results").Range("B14:BF14")

' Set the destination range to start at column B and
' be the same size as the source range.
Set DestRange = SummarySheet.Range("B" & NRow)
Set DestRange = DestRange.Resize(SourceRange.Rows.Count, _
SourceRange.Columns.Count)

' Copy over the values from the source to the destination.
DestRange.Value = SourceRange.Value

' Increase NRow so that we know where to copy data next.
NRow = NRow + DestRange.Rows.Count

' Close the source workbook without saving changes.
WorkBk.Close savechanges:=False

' Use Dir to get the next file name.
FileName = DIR()
Loop

' Call AutoFit on the destination sheet so that all
' data is readable.
SummarySheet.Columns.AutoFit

WorkBk.Application.DisplayAlerts = False
SummarySheet.SaveAs FileName:= _
FolderPath & "\SummarySheet\SummarySheet.xlsx" _
, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
End Sub

最佳答案

这实际上取决于您在何处运行此宏。考虑打开另一个工作簿并将此宏放在工作表或模块后面,让它与所有 99 个源文件和摘要目标文件进行交互。或者,您可以运行 Summary 工作簿中的所有内容,将 Workbooks.Add 更改为 ActiveWorkbook

下面是稍微修改过的 VBA 代码。不要使用范围,而是尝试逐行复制和粘贴。此外,无需调用 Application.Run

Sub MergeAllWorkbooks()
Dim SummaryWkb As Workbook, SourceWkb As Workbook
Dim SummarySheet As Worksheet, SourceWks As Worksheet
Dim FolderPath As String
Dim FileName As Variant
Dim NRow As Long

Set SummaryWkb = Workbooks.Add()
Set SummarySheet = SummaryWkb.Worksheets(1)

FolderPath = "C:\Users\dredden2\Documents\SHAREPOINT ARCHIVING\PAGESETUP\TEST\"
FileName = Dir(FolderPath)

NRow = 1
While (FileName <> "")
If Right(FileName, 4) = "xlsm" Then

Set SourceWkb = Workbooks.Open(FolderPath & FileName)
Set SourceWks = SourceWkb.Sheets("Retrospective Results")

'FILE NAME COPY
SummarySheet.Range("A" & NRow) = FileName

'DATA ROW COPY
SourceWks.Range("B14:BF14").Copy
SummarySheet.Range("B" & NRow).PasteSpecial xlPasteValues

SourceWkb.Close False
NRow = NRow + 1

End If
FileName = Dir
Wend

SummarySheet.Columns.AutoFit
SummaryWkb.SaveAs FileName:=FolderPath & "\SummarySheet\SummarySheet.xlsx" _
, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False

MsgBox "Data successfully extracted!", vbInformation

Set SourceWkb = Nothing
Set SourceWks = Nothing
Set SummarySheet = Nothing
Set SummaryWkb = Nothing
End Sub

关于vba - Excel,循环遍历 XLSM 文件并将行复制到另一张纸,我们在Stack Overflow上找到一个类似的问题: https://stackoverflow.com/questions/29516029/

27 4 0
Copyright 2021 - 2024 cfsdn All Rights Reserved 蜀ICP备2022000587号
广告合作:1813099741@qq.com 6ren.com