Results 1 to 3 of 3
  1. #1
    Lurker
    Join Date
    May 2015
    Posts
    1
    Thanks
    0
    Thanked 0 Times in 0 Posts

    Need help for macro working perfectly on Excel 2010 but not on 2013

    Hi,

    really appriciate your hlep with this.
    I have created a macro for work. It combining, splitting, and changing data. it creates for eample manifest and stores them automatically.
    Now we have changed to Excel 2013 and it is only showing me Run Time Error 9 ...Out of range. Without any possibility to debug.

    here is some of the code

    Code:
    Option Explicit
    
    Public gwksLCP As Worksheet
    
    Sub ManifesteSpeichern()
    
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    
    
    Dim letztezeileT1 As Integer
    Dim letztezeileC As Integer
    Dim strFilename As String
    Dim strFilename1 As String
    Dim Empfänger As String
    Dim Wert As String
    Dim c As Range
    Dim strDatum As String
    Dim StrPath As String
    Dim i As Integer
    
    
    On Error GoTo Fehler
      
    If gwksAusdruck.Range("A2") = "" Then
        MsgBox " KEINE DATEN ZUM AUSDRUCKEN VORHANDEN"
        Exit Sub
    
    
    Else
        strDatum = Format(Date, "YYYY.MM.DD")
            
        If Dir("M:\GTS\GTS_PUBLIC\TRANSIT\MANIFESTE\MANIFESTE-ABLAGE\" & strDatum, vbDirectory) = "" Then
        MkDir ("M:\GTS\GTS_PUBLIC\TRANSIT\MANIFESTE\MANIFESTE-ABLAGE\" & strDatum)
        End If
        Const LW = "M:\"
        StrPath = "M:\GTS\GTS_PUBLIC\TRANSIT\MANIFESTE\MANIFESTE-ABLAGE\" & strDatum & "\"
       
        ChDir LW
        ChDir StrPath
    
    
        Set gwksLCP = ThisWorkbook.Worksheets("LCP-Kunden")
            ''' DATEI WIRD ALS XLS UND PDF GESPEICHERT '''
        Workbooks.Add
        Worksheets(1).Name = "T1-MANIFEST"
        Worksheets(2).Name = "C-MANIFEST"
        Worksheets(3).Delete
        If gwksT1.Range("A2") <> "" And gwksC.Range("A2") = "" Then
            letztezeileT1 = gwksT1.Range("B65536").End(xlUp).Row
            gwksT1.UsedRange.Copy Destination:=ActiveWorkbook.Worksheets("T1-MANIFEST").Range("A1")
            ActiveWorkbook.Worksheets("T1-MANIFEST").Columns("A:N").AutoFit
            AblageFormatieren ActiveWorkbook.Worksheets("T1-MANIFEST")
            ActiveWorkbook.Worksheets("T1-MANIFEST").Range("H:H,J:J").EntireColumn.Hidden = False
            ActiveWorkbook.Worksheets("T1-MANIFEST").Range("O:O").EntireColumn.Hidden = True
            Worksheets(2).Delete
                 
            ActiveWorkbook.Worksheets("T1-MANIFEST").PageSetup.PrintArea = "$A:$N"
                With ActiveWorkbook.Worksheets("T1-MANIFEST").PageSetup
                    .Orientation = xlLandscape
                    .Zoom = 65
                    .PrintTitleRows = "A1:N1"
                    .LeftHeader = "&""Arial,Bold""&10" & "Run Time:" & Now()
                    .CenterHeader = "&""Arial,Bold""&12" & "Federal Express, Heinrich-Steinmann-Str. 9, 51147 Köln" & Chr(13) & "&U" & gwksParameter.Range("G4").Value & "- MANIFEST" & Chr(13) & "ConsNr: " & gwksParameter.Range("G6").Value
                    .RightHeader = "&""Arial,Bold""&11" & "MVT: " & gwksParameter.Range("G2").Value & Chr(13) & "ORG: CGN" & Chr(13) & "&UDEST: " & gwksParameter.Range("G1").Value
                    .CenterFooter = "&""Arial,Bold""&10" & "Fedex GmbH, Heinrich-Steinmann-Str. 9, Flughafen Köln/Bonn,51147 Köln" & Chr(13) & "Seite &P von &N"
                    .PrintTitleRows = "$1:$1"
                End With
    
    
        ElseIf gwksT1.Range("A2") = "" And gwksC.Range("A2") <> "" Then
            letztezeileC = gwksC.Range("B65536").End(xlUp).Row
            gwksC.UsedRange.Copy Destination:=ActiveWorkbook.Worksheets("C-MANIFEST").Range("A1")
            ActiveWorkbook.Worksheets("C-MANIFEST").Columns("A:N").AutoFit
            AblageFormatieren ActiveWorkbook.Worksheets("C-MANIFEST")
            ActiveWorkbook.Worksheets("C-MANIFEST").Range("H:H,J:J").EntireColumn.Hidden = False
            ActiveWorkbook.Worksheets("C-MANIFEST").Range("O:O").EntireColumn.Hidden = True
            Worksheets(1).Delete
                 With ActiveWorkbook.Worksheets("C-MANIFEST").PageSetup
                    .Orientation = xlLandscape
                    .Zoom = 65
                    .PrintTitleRows = "A1:N1"
                    .LeftHeader = "&""Arial,Bold""&10" & "Run Time:" & Now()
                    .CenterHeader = "&""Arial,Bold""&12" & "Federal Express, Heinrich-Steinmann-Str. 9, 51147 Köln" & Chr(13) & "&U" & gwksParameter.Range("G4").Value & "- MANIFEST" & Chr(13) & "ConsNr: " & gwksParameter.Range("G3").Value
                    .RightHeader = "&""Arial,Bold""&11" & "MVT: " & gwksParameter.Range("G2").Value & Chr(13) & "ORG: CGN" & Chr(13) & "&UDEST: " & gwksParameter.Range("G1").Value
                    .CenterFooter = "&""Arial,Bold""&10" & "Fedex GmbH, Heinrich-Steinmann-Str. 9, Flughafen Köln/Bonn,51147 Köln" & Chr(13) & "Seite &P von &N"
                    .PrintTitleRows = "$1:$1"
                End With
    
    
        ElseIf gwksT1.Range("A2") <> "" And gwksC.Range("A2") <> "" Then
            letztezeileT1 = gwksT1.Range("B65536").End(xlUp).Row
            letztezeileC = gwksC.Range("B65536").End(xlUp).Row
            gwksT1.UsedRange.Copy Destination:=ActiveWorkbook.Worksheets("T1-MANIFEST").Range("A1")
            ActiveWorkbook.Worksheets("T1-MANIFEST").Columns("A:N").AutoFit
            AblageFormatieren ActiveWorkbook.Worksheets("T1-MANIFEST")
            ActiveWorkbook.Worksheets("T1-MANIFEST").Range("H:H,J:J").EntireColumn.Hidden = False
            ActiveWorkbook.Worksheets("T1-MANIFEST").Range("O:O").EntireColumn.Hidden = True
            
                With ActiveWorkbook.Worksheets("T1-MANIFEST").PageSetup
                    .Orientation = xlLandscape
                    .Zoom = 65
                    .PrintTitleRows = "A1:N1"
                    .LeftHeader = "&""Arial,Bold""&10" & "Run Time:" & Now()
                    .CenterHeader = "&""Arial,Bold""&12" & "Federal Express, Heinrich-Steinmann-Str. 9, 51147 Köln" & Chr(13) & "&U" & gwksParameter.Range("G5").Value & "- MANIFEST" & Chr(13) & "ConsNr: " & gwksParameter.Range("G6").Value
                    .RightHeader = "&""Arial,Bold""&11" & "MVT: " & gwksParameter.Range("G2").Value & Chr(13) & "ORG: CGN" & Chr(13) & "&UDEST: " & gwksParameter.Range("G1").Value
                    .CenterFooter = "&""Arial,Bold""&10" & "Fedex GmbH, Heinrich-Steinmann-Str. 9, Flughafen Köln/Bonn,51147 Köln" & Chr(13) & "Seite &P von &N"
                    .PrintTitleRows = "$1:$1"
                End With
        
        gwksC.UsedRange.Copy Destination:=ActiveWorkbook.Worksheets("C-MANIFEST").Range("A1")
        ActiveWorkbook.Worksheets("C-MANIFEST").Columns("A:N").AutoFit
        AblageFormatieren ActiveWorkbook.Worksheets("C-MANIFEST")
        ActiveWorkbook.Worksheets("C-MANIFEST").Range("H:H,J:J").EntireColumn.Hidden = False
        ActiveWorkbook.Worksheets("C-MANIFEST").Range("O:O").EntireColumn.Hidden = True
        
            With ActiveWorkbook.Worksheets("C-MANIFEST").PageSetup
                .Orientation = xlLandscape
                .Zoom = 65
                .PrintTitleRows = "A1:N1"
                .LeftHeader = "&""Arial,Bold""&10" & "Run Time:" & Now()
                .CenterHeader = "&""Arial,Bold""&12" & "Federal Express, Heinrich-Steinmann-Str. 9, 51147 Köln" & Chr(13) & "&U" & gwksParameter.Range("G4").Value & "- MANIFEST" & Chr(13) & "ConsNr: " & gwksParameter.Range("G3").Value
                .RightHeader = "&""Arial,Bold""&11" & "MVT: " & gwksParameter.Range("G2").Value & Chr(13) & "ORG: CGN" & Chr(13) & "&UDEST: " & gwksParameter.Range("G1").Value
                .CenterFooter = "&""Arial,Bold""&10" & "Fedex GmbH, Heinrich-Steinmann-Str. 9, Flughafen Köln/Bonn,51147 Köln" & Chr(13) & "Seite &P von &N"
                .PrintTitleRows = "$1:$1"
            End With
        End If
      
        strFilename = getName(StrPath & gwksParameter.Range("G2").Value & "_" & "CGN" & "-" & gwksParameter.Range("G1").Value & "_" & Format(Date, "dd.mm.yyyy"), ".xls")
    
    
        ActiveWorkbook.SaveAs Filename:=strFilename
    
    
        strFilename1 = getName1(StrPath & gwksParameter.Range("G2").Value & "_" & "CGN" & "-" & gwksParameter.Range("G1").Value & "_" & Format(Date, "dd.mm.yyyy"), ".pdf")
    
    
        ActiveWorkbook.ExportAsFixedFormat Type:=xlTypePDF, Filename:=strFilename1, _
                              Quality:=xlQualityStandard, _
                              IncludeDocProperties:=True, IgnorePrintAreas:=False, _
                              OpenAfterPublish:=False
        ActiveWorkbook.Save
    
    
            ''' DATEIEN WERDEN GESENDET '''
                
        Wert = gwksParameter.Range("G1").Value
            
        Set c = gwksLCP.Range("A:A").Find(Wert, LookIn:=xlValues, LookAt:=xlWhole)
    
    
        If Not c Is Nothing Then
           Empfänger = c.Offset(0, 22)
        Else
            MsgBox "Empfänger nicht gefunden, Manifeste wurden gespeichert, Avisierung bitte manuel erledigen!", vbCritical, "E-mail Empfänger nicht gefunden!"
            ActiveWorkbook.Close SaveChanges:=True
            Call Löschen
        Exit Sub
        End If
          
        Dim olApp As Object
        Set olApp = CreateObject("Outlook.Application")
        With olApp.CreateItem(0)
            .Recipients.Add Empfänger
            .CC = "de-gts-nev@corp.ds.fedex.com;transit-cgnip@fedex.com"
            .Attachments.Add strFilename
            .Attachments.Add strFilename1
            .Subject = "T1 PREALERT " & "  " & gwksParameter.Range("G2").Value & "_" & "CGN" & "-" & gwksParameter.Range("G1").Value & " " & "v." & Format(Date, "dd.mm.yyyy")
            .Body = "Hi," & Chr(13) & _
             "Please discharge attached T1" & Chr(13) & Chr(13)
            .ReadReceiptRequested = False
            '.Send
            .Save
        End With
        Set olApp = Nothing
          
        ActiveWorkbook.Close SaveChanges:=True
    End If
    
    
    If Dest = "FRA" And Status = "T1" Then
        Ausgedruckt = True
        gwksT1.Select
        gwksT1.Range("A:A").Delete
        letztezeileT1 = gwksT1.Range("A65536").End(xlUp).Row
        gwksT1.Cells(letztezeileT1 + 2, 4).ClearContents
        gwksT1.Cells(letztezeileT1 + 2, 5).ClearContents
        gwksT1.Cells(letztezeileT1 + 2, 3).ClearContents
        gwksT1.Cells(letztezeileT1 + 2, 2).ClearContents
        For i = 2 To letztezeileT1
            If gwksT1.Cells(i, 3) = "" And gwksT1.Cells(i, 13) <> "" Then
                gwksT1.Rows(i).Delete
                i = i - 1
            End If
        Next
        LVaussortieren gwksT1
        EULänderAsuma gwksT1
        Over gwksT1
            If overs = True Then Exit Sub
        ASUMASkreiren (True)
            If blASUMANothing = False Then
                ASUMASpeichern
            End If
    End If
    Call Löschen
    Exit Sub
    Fehler:
    
    
    MsgBox Err.Number & "  " & Err.Description
    Exit Sub
    
    
    Application.DisplayAlerts = True
    End Sub
    Private Function getName(ByVal strName As String, ByVal strExtension As String) As String
       Dim lngNummer As Long
        
       If Dir(strName & strExtension) = "" Then
          getName = strName & strExtension
       Else
          lngNummer = 1
          While Dir(strName & "_" & lngNummer & strExtension) <> ""
             lngNummer = lngNummer + 1
          Wend
          getName = strName & "_" & lngNummer & strExtension
       End If
    End Function
    Private Function getName1(ByVal strName As String, ByVal strExtension As String) As String
       Dim lngNummer As Long
        
       If Dir(strName & strExtension) = "" Then
          getName1 = strName & strExtension
       Else
          lngNummer = 1
          While Dir(strName & "_" & lngNummer & strExtension) <> ""
             lngNummer = lngNummer + 1
          Wend
          getName1 = strName & "_" & lngNummer & strExtension
       End If
    End Function
    Sub AblageFormatieren(x As Worksheet)
    x.Activate
    Range("B:B,C:C").EntireColumn.ColumnWidth = 15  ' Feste Breite für Spalten
    Range("A:A,D:D,E:E,H:H,J:J,M:M").EntireColumn.ColumnWidth = 5
    Range("G:G").EntireColumn.ColumnWidth = 35
    Range("H:H,J:J").EntireColumn.ColumnWidth = 3
    Range("I:I,K:K").EntireColumn.ColumnWidth = 20
    Range("L:L").EntireColumn.ColumnWidth = 8
    Range("E:E").EntireColumn.ColumnWidth = 7
    
    
    einrahmen Range("A1:N1")
    
    
    With x.UsedRange                'Feste Breite
        .RowHeight = 20
    End With
    End Sub
    Public Sub einrahmen(x As Range)
    x.Borders.Weight = xlThin
    End Sub




    COPY.xlsm


    The whole macro attachet as well
    Last edited by RetiredGeek; 2015-05-14 at 10:47.

  2. #2
    WS Lounge VIP rory's Avatar
    Join Date
    Dec 2000
    Location
    Burwash, East Sussex, United Kingdom
    Posts
    6,280
    Thanks
    3
    Thanked 191 Times in 177 Posts
    Comment out this line:
    Code:
    On Error GoTo Fehler
    and then run the code again which should allow you to debug. It may be simply that your default workbook doesn't have 3 sheets (the code just assumes it will).
    Regards,
    Rory

    Microsoft MVP - Excel

  3. #3
    New Lounger
    Join Date
    Jun 2015
    Location
    India
    Posts
    1
    Thanks
    0
    Thanked 0 Times in 0 Posts
    nice post thank you

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •