debugging VBA Excel宏错误

fxnxkyjh 于 2022-12-19 发布在其他

关注(0)|答案(1)|浏览(127)

由于某种原因，每当我运行这个程序时，它会产生一个不完整的输出，它似乎是从另一个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

debugging

来源：https://stackoverflow.com/questions/74741454/vba-excel-macros-bug

1条答案

按热度按时间

zc0qhyus1#

将PrintArray插入到sub中的问题是由于您的Array被填满的速度比您想象的要快得多。

Do While strFile <> ""
 counter = counter + 1
 strFile = Dir
 Loop

只会计算文件的数量，但我想象工作表的数量超过工作簿的数量+25
无论如何，如果你只想打印一次，我把PrintArray放在循环中的假设是错误的，除非在循环中打印是好的，但是你必须跟踪你最后结束的地方，清空/重新填充你的数组。

Sub excel_report()

    Dim strFile As String, strInFold As String, extension As String
    Dim ExlApp As Excel.Application
    Dim wbk As Workbook
    Dim ws As Worksheet, sheetpage As Page
    Dim counter As Long, index As Long, shtCount As Long, newEnd As Long, i As Long, j As Long
    Dim sets() As String, helpArr() As String
    Dim pgs As Integer, 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(25, 2) 'we'll use Redim Preserve which only works on the outer dimension so we have to switch our inputting
    
    'show the file location in the array
    sets(0, 0) = "File Location"
    sets(1, 0) = strInFold
    
    're name the first rows as the title of the values below
    
    sets(0, 1) = "File Name"
    sets(1, 1) = "Header Left"
    sets(2, 1) = "Header Center"
    sets(3, 1) = "Header Right"
    sets(4, 1) = "Footer Left"
    sets(5, 1) = "Footer Center"
    sets(6, 1) = "Footer Right"
    sets(7, 1) = "Different First Page Header Left"
    sets(8, 1) = "Different First Page Header Center"
    sets(9, 1) = "Different First Page Header Right"
    sets(10, 1) = "Different First Page Footer Left"
    sets(11, 1) = "Different First Page Footer Center"
    sets(12, 1) = "Different First Page Footer Right"
    sets(13, 1) = "Even page Header Left"
    sets(14, 1) = "Even page Header Center"
    sets(15, 1) = "Even page Header Right"
    sets(16, 1) = "Even page Footer Left"
    sets(17, 1) = "Even page Footer Center"
    sets(18, 1) = "Even page Footer Right"
    sets(19, 1) = "Odd Header Left"
    sets(20, 1) = "Odd Header Center"
    sets(21, 1) = "Odd Header Right"
    sets(22, 1) = "Odd Footer Left"
    sets(23, 1) = "Odd Footer Center"
    sets(24, 1) = "Odd Footer Right"
    
    're use counter 1 as a row positioniong variable
    counter = 1 '~~~~ set it to 1 since I'm adding the counter on each sheet
    
    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 '~~~~ what is index supposed to be used for?
        pgs = 1
        shtCount = wbk.Sheets.Count
        newEnd = UBound(sets, 2) + shtCount
        ReDim Preserve sets(25, newEnd)
        For Each ws In wbk.Worksheets
            If ws.Visible = xlSheetHidden Then
                ws.Visible = xlSheetVisible
                wbk.Save
            End If
            
            counter = counter + 1
            sets(0, counter) = strFile & " Sheet " & index
            
            wspgs = ws.PageSetup.Pages.Count '~~~~ also unused variable
                '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(7, counter) = ws.PageSetup.FirstPage.LeftHeader.Text
                    sets(8, counter) = ws.PageSetup.FirstPage.CenterHeader.Text
                    sets(9, counter) = ws.PageSetup.FirstPage.RightHeader.Text
                    sets(10, counter) = ws.PageSetup.FirstPage.LeftFooter.Text
                    sets(11, counter) = ws.PageSetup.FirstPage.CenterFooter.Text
                    sets(12, counter) = 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(13, counter) = ws.PageSetup.EvenPage.LeftHeader.Text
                        sets(14, counter) = ws.PageSetup.EvenPage.CenterHeader.Text
                        sets(15, counter) = ws.PageSetup.EvenPage.RightHeader.Text
                        sets(16, counter) = ws.PageSetup.EvenPage.LeftFooter.Text
                        sets(17, counter) = ws.PageSetup.EvenPage.CenterFooter.Text
                        sets(18, counter) = ws.PageSetup.EvenPage.RightFooter.Text
                    ElseIf pgs Mod 2 = 1 Then
                        sets(19, counter) = ws.PageSetup.LeftHeader
                        sets(20, counter) = ws.PageSetup.CenterHeader
                        sets(21, counter) = ws.PageSetup.RightHeader
                        sets(22, counter) = ws.PageSetup.LeftFooter
                        sets(23, counter) = ws.PageSetup.CenterFooter
                        sets(24, counter) = ws.PageSetup.RightFooter
                    End If
                Else
                    sets(1, counter) = wbk.Worksheets(index).PageSetup.LeftHeader
                    sets(2, counter) = wbk.Worksheets(index).PageSetup.CenterHeader
                    sets(3, counter) = wbk.Worksheets(index).PageSetup.RightHeader
                    sets(4, counter) = wbk.Worksheets(index).PageSetup.LeftFooter
                    sets(5, counter) = wbk.Worksheets(index).PageSetup.CenterFooter
                    sets(6, counter) = wbk.Worksheets(index).PageSetup.RightFooter
                End If
            pgs = pgs + 1
        '    Next pgs
            Next sheetpage
            
            'move to next row
            index = index + 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
    '~~~~ but first let's reverse our sets to the proper order, helpArray since I don't believe Word supports transpose
    Redim helpArr(counter, 25)
    For i = 0 To 24
        For j = 0 To counter
            helpArr(j, i) = sets(i, j)
        Next j
    Next i
    PrintArray helpArr, ActiveWorkbook.Worksheets("Excel").[A1]
End Sub

我无法测试它，所以请让我知道这是否适合你，或者如果你仍然遇到问题。

赞(0）回复(0）举报 2022-12-19

我来回答

debugging VBA Excel宏错误

1条答案

相关问题

热门标签

最新问答