在2或3页上运行宏

Question

为我提供了一个可以使用的宏，它可以在1 pg工作表上正常工作，但是我的一些工作表有2或3页。知道如何将代码更改为一页以上吗？任何反馈表示赞赏。这是宏代码：

Dim wksAufruf As Worksheet

Dim wkbAufruf As Workbook

Dim wksActive As Worksheet

Dim varDatei As Variant

Option Explicit

Sub DateiAufrufen()
Dim s As String

Set wksActive = ThisWorkbook.Sheets(1)
s = wksActive.Cells(3, 2).Value
'ChDrive                ' drive specification
    ChDir s             ' path specification for the selection dialog"
    varDatei = Application.GetOpenFilename("Excel-Dateien (*.xls*), *.xl*")
    Set wkbAufruf = Workbooks.Open(varDatei, False, True)
    Set wksAufruf = wkbAufruf.Sheets(1)
End Sub
Sub DateiErstellen()

'###admin read out

Dim out As String           'output folder path
Dim head As String          'row of column-headlines
Dim filetype As String      'output filetype

out = wksActive.Cells(5, 2).Value     'output folder path
head = wksActive.Cells(7, 2).Value
If Right(out, 1) <> "\" Then
    out = out & "\"
End If

filetype = wksActive.Cells(9, 2).Value
filetype = Replace(filetype, ".", "")

'###create new file

Dim FSyObjekt As Object     'to create new file

Application.ScreenUpdating = False
Set FSyObjekt = CreateObject("Scripting.FileSystemObject")
Workbooks.Add
Set wksActive = ActiveWorkbook.Sheets(1)

'###pre-work copy data

Dim name As String
Dim r As Integer
Dim c As Integer
Dim r1 As Integer           'row wksActive
Dim i1 As Integer           'row wksAufruf
Dim i2 As Integer           'column wksAufruf
Dim rel As Integer          'first column released


r = wksAufruf.UsedRange.Rows.Count          'last row wksAufruf
c = wksAufruf.UsedRange.Columns.Count       'last column wksAufruf
name = wkbAufruf.name                       'file name
r1 = 1

For i2 = 1 To c
    If wksAufruf.Cells(head - 1, i2) Like "*RELEASED*" Then
        rel = i2
        Exit For
    End If
Next i2


'###Copy Data
Dim s As String

For i1 = 1 To r
    For i2 = 1 To c
        If i1 = head Then
            s = wksAufruf.Cells(i1, i2) & " " & wksAufruf.Cells(i1 + 1, i2)       'because column headlines in Hawker's lists stretch over two rows
            If i2 = c Then
                i1 = i1 + 1
            End If
        Else
            s = wksAufruf.Cells(i1, i2).Value
        End If
        wksActive.Cells(r1, i2) = s
    Next i2
    r1 = r1 + 1
Next i1

wkbAufruf.Close False       'close without saving

ActiveWorkbook.Sheets(2).Delete     'close cheets 2 and 3 of the newly created worksheet
ActiveWorkbook.Sheets(2).Delete

'delete upper row
For i1 = 1 To head - 1
    Rows("1").EntireRow.Delete
Next i1

'delete bottom row
r = wksActive.UsedRange.Rows.Count
For r1 = 1 To r
    If wksActive.Cells(r1, 3).Value = "" Then
        Exit For                                'find row to delete
    End If
Next r1

i1 = r1
For r1 = i1 To r
    wksActive.Rows(i1).EntireRow.Delete
Next r1


For i2 = 1 To c                                                                                                              'delete empty columns
    If wksActive.Cells(1, i2).Value = "" Or wksActive.Cells(1, i2).Value = " " Or wksActive.Cells(1, i2).Value = "  " _
    Or wksActive.Cells(1, i2).Value = "   " Or wksActive.Cells(1, i2).Value = "    " Or wksActive.Cells(1, i2).Value = "     " Then
        wksActive.Columns(i2).EntireColumn.Delete
        If i2 <= rel Then
            rel = rel - 1
        End If

        If i2 = c Then
            Exit For
        End If

        i2 = i2 - 1
        c = c - 1
    End If
Next i2

'released and received
For i2 = 1 To wksActive.UsedRange.Columns.Count
    s = ""
    If i2 > 1 And i2 < rel Then
        s = "RECEIVED " & wksActive.Cells(1, i2)
    ElseIf i2 >= rel And i2 < wksActive.UsedRange.Columns.Count Then
        s = "RELEASED " & wksActive.Cells(1, i2)
    Else
        s = wksActive.Cells(1, i2)
    End If
    wksActive.Cells(1, i2) = s
Next i2

Modul2.ColumnManagement wksActive

Dim k As Integer
k = InStr(1, name, ".")
name = Left(name, k - 1)

ActiveWorkbook.SaveAs out & "FD_" & name & "." & filetype
ActiveWorkbook.Close

End Sub

Sub main()
    DateiAufrufen
    DateiErstellen
End Sub