Zystkmt

I was given a macro to use, it works fine with 1 pg worksheets but some of my worksheets have 2 or 3 pages. Any idea how I can change the code to do more than 1 page? Any feedback is appreciated. Here is the macro code:

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