【发布时间】：2022-12-14 19:06:45
【问题描述】：
出于某种原因，每当我最初运行该程序时，它都会产生不完整的输出。它似乎从我从中获取数据的另一个 excel 文件的最后一个选定工作表开始，这是它显示的唯一输出。
我试着打开宏代码，一切都正常输出，但只要代码关闭，输出就不完整。所以这是该工具的完整代码。这里真的需要一些帮助，我不知道这是由这么多数组引起的错误还是有一些不正确的代码。
Option Explicit
Public savepath As String
'This will select the file/folder
Function select_folder2()
Dim Filepicker As FileDialog
Dim mypath As String
Set Filepicker = Application.FileDialog(msoFileDialogFolderPicker)
With Filepicker
.Title = "Select folder"
.AllowMultiSelect = False
.InitialFileName = Application.DefaultFilePath
.ButtonName = "Select(&S)"
If .Show = -1 Then
mypath = .SelectedItems(1) & "\"
Else
End
End If
End With
NextCode:
Set Filepicker = Nothing
savepath = mypath
End Function
Sub PrintArray(data As Variant, Cl As Range)
Cl.Resize(UBound(data, 1), UBound(data, 2)) = data
End Sub
Sub excel_report()
Dim strFile As String
Dim strInFold As String
Dim extension As String
Dim ExlApp As Excel.Application
Dim wbk As Workbook
Dim ws As Worksheet, sheetpage As Page
Dim counter As Long
Dim index As Long
Dim sets() As String
Dim pgs As Integer
Dim wspgs As Integer
'count the files in the folder
strInFold = savepath
extension = "*.xls*"
strFile = Dir(strInFold & extension)
Do While strFile <> ""
counter = counter + 1
strFile = Dir
Loop
ReDim sets(counter + 25, 25)
'save values of files into an array
strInFold = savepath
extension = "*.xls*"
strFile = Dir(strInFold & extension)
'show the file location in the array
sets(0, 0) = "File Location"
sets(0, 1) = strInFold
're name the first rows as the title of the values below
sets(1, 0) = "File Name"
sets(1, 1) = "Header Left"
sets(1, 2) = "Header Center"
sets(1, 3) = "Header Right"
sets(1, 4) = "Footer Left"
sets(1, 5) = "Footer Center"
sets(1, 6) = "Footer Right"
sets(1, 7) = "Different First Page Header Left"
sets(1, 8) = "Different First Page Header Center"
sets(1, 9) = "Different First Page Header Right"
sets(1, 10) = "Different First Page Footer Left"
sets(1, 11) = "Different First Page Footer Center"
sets(1, 12) = "Different First Page Footer Right"
sets(1, 13) = "Even page Header Left"
sets(1, 14) = "Even page Header Center"
sets(1, 15) = "Even page Header Right"
sets(1, 16) = "Even page Footer Left"
sets(1, 17) = "Even page Footer Center"
sets(1, 18) = "Even page Footer Right"
sets(1, 19) = "Odd Header Left"
sets(1, 20) = "Odd Header Center"
sets(1, 21) = "Odd Header Right"
sets(1, 22) = "Odd Footer Left"
sets(1, 23) = "Odd Footer Center"
sets(1, 24) = "Odd Footer Right"
're use counter 1 as a row positioniong variable
counter = 2
Do While strFile <> ""
'open excel application
On Error Resume Next
' Check whether excel is running
Set ExlApp = GetObject(, "Excel.Application")
If ExlApp Is Nothing Then
' Word is not running, create new instance
Set ExlApp = CreateObject("Excel.Application")
' For automation to work, excel must be visible
ExlApp.Visible = True
End If
On Error GoTo 0
DoEvents
' open file
Set wbk = ExlApp.Workbooks.Open(strInFold & strFile)
index = 1
pgs = 1
For Each ws In wbk.Worksheets
If ws.Visible = xlSheetHidden Then
ws.Visible = xlSheetVisible
wbk.Save
End If
sets(counter, 0) = strFile & " Sheet " & index
wspgs = ws.PageSetup.Pages.Count
'assign the filename, headers, and footers value from the currently opened file into the array
For Each sheetpage In ws.PageSetup.Pages
' Sheet1.Select
' For pgs = 1 To wspgs
If ws.PageSetup.DifferentFirstPageHeaderFooter = True Then
sets(counter, 7) = ws.PageSetup.FirstPage.LeftHeader.Text
sets(counter, 8) = ws.PageSetup.FirstPage.CenterHeader.Text
sets(counter, 9) = ws.PageSetup.FirstPage.RightHeader.Text
sets(counter, 10) = ws.PageSetup.FirstPage.LeftFooter.Text
sets(counter, 11) = ws.PageSetup.FirstPage.CenterFooter.Text
sets(counter, 12) = ws.PageSetup.FirstPage.RightFooter.Text
' Else
' sets(counter, 1) = wbk.Worksheets(index).PageSetup.LeftHeader
' sets(counter, 2) = wbk.Worksheets(index).PageSetup.CenterHeader
' sets(counter, 3) = wbk.Worksheets(index).PageSetup.RightHeader
' sets(counter, 4) = wbk.Worksheets(index).PageSetup.LeftFooter
' sets(counter, 5) = wbk.Worksheets(index).PageSetup.CenterFooter
' sets(counter, 6) = wbk.Worksheets(index).PageSetup.RightFooter
End If
If ws.PageSetup.OddAndEvenPagesHeaderFooter = True Then
If pgs Mod 2 = 0 Then
sets(counter, 13) = ws.PageSetup.EvenPage.LeftHeader.Text
sets(counter, 14) = ws.PageSetup.EvenPage.CenterHeader.Text
sets(counter, 15) = ws.PageSetup.EvenPage.RightHeader.Text
sets(counter, 16) = ws.PageSetup.EvenPage.LeftFooter.Text
sets(counter, 17) = ws.PageSetup.EvenPage.CenterFooter.Text
sets(counter, 18) = ws.PageSetup.EvenPage.RightFooter.Text
ElseIf pgs Mod 2 = 1 Then
sets(counter, 19) = ws.PageSetup.LeftHeader
sets(counter, 20) = ws.PageSetup.CenterHeader
sets(counter, 21) = ws.PageSetup.RightHeader
sets(counter, 22) = ws.PageSetup.LeftFooter
sets(counter, 23) = ws.PageSetup.CenterFooter
sets(counter, 24) = ws.PageSetup.RightFooter
End If
Else
sets(counter, 1) = wbk.Worksheets(index).PageSetup.LeftHeader
sets(counter, 2) = wbk.Worksheets(index).PageSetup.CenterHeader
sets(counter, 3) = wbk.Worksheets(index).PageSetup.RightHeader
sets(counter, 4) = wbk.Worksheets(index).PageSetup.LeftFooter
sets(counter, 5) = wbk.Worksheets(index).PageSetup.CenterFooter
sets(counter, 6) = wbk.Worksheets(index).PageSetup.RightFooter
End If
pgs = pgs + 1
' Next pgs
Next sheetpage
'move to next row
index = index + 1
counter = counter + 1
Next ws
wbk.Close
strFile = Dir
Loop
'use the printarray sub to print the array (arry) into the "Word" sheet, start with column and row A1
PrintArray sets, ActiveWorkbook.Worksheets("Excel").[A1]
End Sub
【问题讨论】：
-
如果您的 PrintArray 在循环之外，则只获取最后一个循环的值是正常的，因为您的
sets值在每个循环中都会被覆盖（除非我误读了您的代码）。 -
我已经尝试在循环中包含 printarray，这会导致错误。此序列也适用于代码的 word 和 ppt 部分。只有这部分在 excel 中表现不当。
-
您遇到了哪个错误，然后将 PrintArray 放在哪里？
-
当我将 printarray 放入循环中时，出现“下标超出范围”错误。对于我放置 printarray 的所有序列都不是问题，因为它可以与另一组代码一起正常工作。
标签： excel vba debugging export-to-excel