Fehlermeldung: Subscript out of range
30.09.2010 13:55:57
abu
Hallo xr8k2 und Alle,
habe den Code jetzt mal ueberarbeitet nach meinem koenen.
Workbooks("ASNs completed inventorynieuw.xls").Worksheets("damage waterlekkage completed"). _
Activate
Leider bekomme ich bei dieser Zeile immer eine Fehlermeldung. Da der selbe Code aber vorher schon durchlaeuft (nur mit anderem Tabellennamen) verstehe ich nicht warum dieser Fehler auftritt.
Hat jemand vllt. eine Idee was ich falsch mache?
Hier der komplette Code:
Sub Hans()
Dim strAsn As String 'Pfad + Dateiname
Dim oFilter As Object, rngG As Range, ar As Variant, i As Integer 'um filter spaeter _
setzten zu koennen
Call Datei_speichern
strAsn = "G:\Sites\Beringe2\Kyocera\KME\Warehouse\Returns\ASNs completed inventorynieuw\ _
ASNs completed inventorynieuw.xls"
'*********************************************************************************************** _
If WorksheetExists("WarehouseDHL") Then 'pruefen ob tabelle besteht
Worksheets("WarehouseDHL").Activate
With Worksheets("WarehouseDHL")
If Cells(2, 1).Value "" Then 'pruefen ob daten in Zelle A2 _
stehen
Columns("A:B").Select ' 2Spalten einfuegen
Selection.Insert Shift:=xlToRight
Cells(1, 1).Value = "Week"
Cells(1, 2).Value = "DHL / non DHL"
Range("C1").Copy 'formate von C1 auf A! und B1 _
uebertragen
Range("A1:B1").PasteSpecial Paste:=xlPasteFormats
Cells.Select ' alle raenderformate weg
With Selection
.Borders(xlDiagonalDown).LineStyle = xlNone
.Borders(xlDiagonalUp).LineStyle = xlNone
.Borders(xlEdgeLeft).LineStyle = xlNone
.Borders(xlEdgeTop).LineStyle = xlNone
.Borders(xlEdgeBottom).LineStyle = xlNone
.Borders(xlEdgeRight).LineStyle = xlNone
.Borders(xlInsideVertical).LineStyle = xlNone
.Borders(xlInsideHorizontal).LineStyle = xlNone
End With
Range("A1:L" & leZeile).Select 'formate fuer drucken _
vorbereiten
With Selection
.Borders(xlDiagonalDown).LineStyle = xlNone
.Borders(xlDiagonalUp).LineStyle = xlNone
.Borders(xlEdgeLeft).LineStyle = xlContinuous
.Borders(xlEdgeLeft).Weight = xlThin
.Borders(xlEdgeLeft).ColorIndex = xlAutomatic
.Borders(xlEdgeTop).LineStyle = xlContinuous
.Borders(xlEdgeTop).Weight = xlThin
.Borders(xlEdgeTop).ColorIndex = xlAutomatic
.Borders(xlEdgeBottom).LineStyle = xlContinuous
.Borders(xlEdgeBottom).Weight = xlThin
.Borders(xlEdgeBottom).ColorIndex = xlAutomatic
.Borders(xlEdgeRight).LineStyle = xlContinuous
.Borders(xlEdgeRight).Weight = xlThin
.Borders(xlEdgeRight).ColorIndex = xlAutomatic
.Borders(xlInsideVertical).LineStyle = xlContinuous
.Borders(xlInsideVertical).Weight = xlThin
.Borders(xlInsideVertical).ColorIndex = xlAutomatic
.Borders(xlInsideHorizontal).Weight = xlThin
End With
Range("A2:A" & leZeile).Value = dt_Kalenderwoche(Date) 'wochennummer _
in spalte a schreiben
'aufsteigen _
nach LUID sortieren
Range("A1:L" & leZeile).Sort Key1:=Range("G1"), Order1:=xlAscending, Header:= _
xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
Cells.Select 'formatierung _
zum drucken
With Selection
Cells.EntireColumn.AutoFit
Columns("H:H").ColumnWidth = 15.5
End With
With ActiveSheet.PageSetup
.Orientation = xlLandscape
.LeftMargin = Application.InchesToPoints(0.2)
.RightMargin = Application.InchesToPoints(0.2)
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = 1
End With
Set oFilter = CreateObject("Scripting.dictionary") 'schleife _
fuer drucken
For Each rngG In Range(Cells(2, 7), Cells(Rows.Count, 7).End(xlUp))
oFilter(rngG.Value) = rngG.Value
Next
ar = oFilter.Keys
For i = 0 To UBound(ar)
Cells(1, 1).AutoFilter Field:=5, Criteria1:=ar(i)
Call Msg_Box 'ActiveSheet.PrintOut From:=1, To:=1, Copies:=1, Collate:=True
Next
ActiveSheet.ShowAllData
Columns("D:D").Select ' _
formatierungen um ASN datei zu kopieren
Selection.Insert Shift:=xlToRight
Cells(1, 4).Value = "Year"
Range("D2:D" & leZeile).Value = Year(Now)
End If
End With
End If
obiger Code kommt nun noch 2mal fuer 2 andere Tabellen in der Datei
Application.Workbooks.Open Filename:=strAsn, UpdateLinks:=False
Workbooks("Tempfile.xls").Activate
If WorksheetExists("WarehouseDHL") And Worksheets("WarehouseDHL").Cells(2, 1).Value "" Then 'ab hier kopieren in ASN
Worksheets("WarehouseDHL").Activate
Range("A2:L" & leZeile).Copy 'kopieren
Workbooks("ASNs completed inventorynieuw.xls").Worksheets("completed whd").Activate
Cells(leZeile + 1, 1).Select 'erste freie Zelle ermitteln
ActiveSheet.Paste 'kopieren
End If
Workbooks("Tempfile.xls").Activate
If WorksheetExists("RETURNS") And Worksheets("RETURNS").Cells(2, 1).Value "" Then 'ab hier kopieren in ASN
Worksheets("RETURNS").Activate
Range("A2:L" & leZeile).Copy 'kopieren
Workbooks("ASNs completed inventorynieuw.xls").Worksheets("completed returns").Activate
Cells(leZeile + 1, 1).Select 'erste freie Zelle ermitteln
ActiveSheet.Paste 'kopieren
End If
Workbooks("Tempfile.xls").Activate
If WorksheetExists("Warehouse not DHL") And Worksheets("Warehouse not DHL").Cells(2, 1).Value "" Then 'ab hier kopieren in ASN
Worksheets("Warehouse not DHL").Activate
Range("A2:L" & leZeile).Copy 'kopieren
Workbooks("ASNs completed inventorynieuw.xls").Worksheets("damage waterlekkage completed").Activate
Cells(leZeile + 1, 1).Select 'erste freie Zelle ermitteln
ActiveSheet.Paste 'kopieren
End If
ActiveWorkbook.Close SaveChanges:=True 'ASN datei schliessen
Workbooks("Tempfile.xls").Activate
ActiveWorkbook.Close SaveChanges:=False
Kill "H:\Templates\Tempfile.xls" 'tempdatei loeschen
End Sub
Public Function WorksheetExists(ByVal WorksheetName As String) As Boolean
On Error Resume Next
WorksheetExists = (Sheets(WorksheetName).Name "")
On Error GoTo 0
End Function
Function leZeile() As Long
leZeile = CLng(Range(ActiveSheet.Range("A:IV").Find(What:="*", _
After:=Range("A65536"), LookIn:=xlValues, LookAt:=xlWhole, _
SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Address).Row)
End Function
Gruss
abu