Hallo Zusammen,
Ich soll ein Makro verwenden, welches ich nicht selber gebaut habe und welches für eine geringe Datenmenge auch funktioniert, aber sobald die Textdatei größer wird, dann kommt eben diese Fehlermeldung. Da ich nicht sehr bewandert in VBA bin, habe ich es bisher nicht geschafft, eine Lösung für das Problem zu finden.. Deswegen dachte ich, dass Ihr es vielleicht sofort seht :-) Vielen Dank schonmal!
Hier das Makro (ich markiere den Teil, der immer aufkommt bei der Fehlermeldung!):
Sub InputAccountingForm()
Dim LRow As Long
Dim Criterium1, Criterium2, Criterium3, Criterium4, Criterium5, Criterium6, Criterium7, Criterium8 As String
'Instruction to insert a file
Dim Instruction1 As String
Instruction1 = "For the beginning please select a text file that contains the 'Accounting Form 1' information. "
MsgBox Instruction1
'insert File
Dim MyFile As String
MyFile = Application.GetOpenFilename()
Workbooks.Open (MyFile)
'
' textToColumnsFromInsertedFile
'
Columns("A:A").Select
Selection.TextToColumns Destination:=Range("A1"), DataType:=xlFixedWidth, FieldInfo:= _
Array(Array(0, 1), Array(18, 1), Array(23, 1), Array(35, 1), Array(45, 1), Array(57, 1), _
Array(72, 1), Array(86, 1), Array(98, 1), Array(103, 1)), TrailingMinusNumbers:=True
Criterium1 = "ULD No."
Criterium2 = "*020-*"
Criterium3 = "*Agent*"
Criterium4 = "*Freight No*"
Criterium5 = "*Freight Date*"
Criterium6 = "*Gross Weight*"
Criterium7 = "*Add Hoc*"
Criterium8 = "*Remark*"
'Inserts a new column in A
Range("A1").Select
Selection.EntireColumn.Insert
'Checks if Row 2 contains one of the criteria 2-8 listed above and if yes puts a "1" into the first column
For LRow = 1 To ActiveWorkbook.ActiveSheet.Cells(Rows.Count, 2).End(xlUp).Row + 10
If ActiveWorkbook.ActiveSheet.Cells(LRow, 2).Value Like Criterium2 Or ActiveWorkbook.ActiveSheet.Cells(LRow, 2).Value Like Criterium3 Or ActiveWorkbook.ActiveSheet.Cells(LRow, 2).Value Like Criterium4 Or ActiveWorkbook.ActiveSheet.Cells(LRow, 2).Value Like Criterium5 Or ActiveWorkbook.ActiveSheet.Cells(LRow, 2).Value Like Criterium6 Or ActiveWorkbook.ActiveSheet.Cells(LRow, 2).Value Like Criterium7 Or ActiveWorkbook.ActiveSheet.Cells(LRow, 2).Value Like Criterium8 Then
ActiveWorkbook.ActiveSheet.Cells(LRow, 1) = "1"
End If
Next LRow
'Checks if Row 2 contains criteria1 listed above and if yes puts a "1" into column A, 2 rows down (at ULD Number)
For LRow = 1 To ActiveWorkbook.ActiveSheet.Cells(Rows.Count, 2).End(xlUp).Row + 10
If ActiveWorkbook.ActiveSheet.Cells(LRow, 2).Value Like Criterium1 Then
ActiveWorkbook.ActiveSheet.Cells(LRow + 2, 1) = "1"
End If
Next LRow
'Deletes all Rows except for column A contains 1
Dim i As Long
For i = ActiveWorkbook.ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row + 10 To 1 Step -1
If IsEmpty(Cells(i, 1)) Then Rows(i).EntireRow.Delete
If Not ActiveWorkbook.ActiveSheet.Cells(i, 1) = 1 Then Rows(i).EntireRow.Delete
Next
'Inserts 10 new columns to the front
Range("A1").Select
Selection.EntireColumn.Insert
Range("A1").Select
Selection.EntireColumn.Insert
Range("A1").Select
Selection.EntireColumn.Insert
Range("A1").Select
Selection.EntireColumn.Insert
Range("A1").Select
Selection.EntireColumn.Insert
Range("A1").Select
Selection.EntireColumn.Insert
Range("A1").Select
Selection.EntireColumn.Insert
Range("A1").Select
Selection.EntireColumn.Insert
Range("A1").Select
Selection.EntireColumn.Insert
Range("A1").Select
Selection.EntireColumn.Insert
'Checks if row contains AWB information and puts respective pallet information into same row
For LRow = 8 To ActiveWorkbook.ActiveSheet.Cells(Rows.Count, 12).End(xlUp).Row
'IF AWB above selected row, then adopt ULD values
If ActiveWorkbook.ActiveSheet.Cells(LRow - 1, 12).Value Like Criterium2 And ActiveWorkbook.ActiveSheet.Cells(LRow, 12).Value Like Criterium2 Then
ActiveWorkbook.ActiveSheet.Cells(LRow, 1) = ActiveWorkbook.ActiveSheet.Cells(LRow - 1, 1)
ActiveWorkbook.ActiveSheet.Cells(LRow, 2) = ActiveWorkbook.ActiveSheet.Cells(LRow - 1, 2)
ActiveWorkbook.ActiveSheet.Cells(LRow, 3) = ActiveWorkbook.ActiveSheet.Cells(LRow - 1, 3)
ActiveWorkbook.ActiveSheet.Cells(LRow, 4) = ActiveWorkbook.ActiveSheet.Cells(LRow - 1, 4)
ActiveWorkbook.ActiveSheet.Cells(LRow, 5) = ActiveWorkbook.ActiveSheet.Cells(LRow - 1, 5)
ActiveWorkbook.ActiveSheet.Cells(LRow, 6) = ActiveWorkbook.ActiveSheet.Cells(LRow - 1, 6)
ActiveWorkbook.ActiveSheet.Cells(LRow, 7) = ActiveWorkbook.ActiveSheet.Cells(LRow - 1, 7)
ActiveWorkbook.ActiveSheet.Cells(LRow, 8) = ActiveWorkbook.ActiveSheet.Cells(LRow - 1, 8)
ActiveWorkbook.ActiveSheet.Cells(LRow, 9) = ActiveWorkbook.ActiveSheet.Cells(LRow - 1, 9)
ActiveWorkbook.ActiveSheet.Cells(LRow, 10) = ActiveWorkbook.ActiveSheet.Cells(LRow - 1, 10)
ActiveWorkbook.ActiveSheet.Cells(LRow, 11) = ActiveWorkbook.ActiveSheet.Cells(LRow - 1, 11)
Else
If ActiveWorkbook.ActiveSheet.Cells(LRow, 12).Value Like Criterium2 And ActiveWorkbook.ActiveSheet.Cells(LRow - 1, 12).Value Like Criterium8 Then 'IF no AWB above selected row and no pallet information available (=loose), then insert loose information
ActiveWorkbook.ActiveSheet.Cells(LRow, 1) = ActiveWorkbook.ActiveSheet.Cells(LRow - 6, 14) & ActiveWorkbook.ActiveSheet.Cells(LRow - 6, 15) & ActiveWorkbook.ActiveSheet.Cells(LRow - 6, 16) & ActiveWorkbook.ActiveSheet.Cells(LRow - 6, 17)
ActiveWorkbook.ActiveSheet.Cells(LRow, 2) = ActiveWorkbook.ActiveSheet.Cells(LRow - 5, 14)
ActiveWorkbook.ActiveSheet.Cells(LRow, 3) = ActiveWorkbook.ActiveSheet.Cells(LRow - 4, 14)
ActiveWorkbook.ActiveSheet.Cells(LRow, 4) = ActiveWorkbook.ActiveSheet.Cells(LRow - 3, 14)
ActiveWorkbook.ActiveSheet.Cells(LRow, 5) = ActiveWorkbook.ActiveSheet.Cells(LRow - 2, 14)
ActiveWorkbook.ActiveSheet.Cells(LRow, 6) = ActiveWorkbook.ActiveSheet.Cells(LRow - 1, 14) & ActiveWorkbook.ActiveSheet.Cells(LRow - 1, 15) & ActiveWorkbook.ActiveSheet.Cells(LRow - 1, 16) & ActiveWorkbook.ActiveSheet.Cells(LRow - 1, 17) & ActiveWorkbook.ActiveSheet.Cells(LRow - 1, 18)
ActiveWorkbook.ActiveSheet.Cells(LRow, 7) = "loose"
ActiveWorkbook.ActiveSheet.Cells(LRow, 8) = "loose"
ActiveWorkbook.ActiveSheet.Cells(LRow, 9) = "loose"
ActiveWorkbook.ActiveSheet.Cells(LRow, 10) = "loose"
ActiveWorkbook.ActiveSheet.Cells(LRow, 11) = "loose"
Else
If ActiveWorkbook.ActiveSheet.Cells(LRow, 12).Value Like Criterium2 Then 'IF no AWB above selected row, but pallet information available, then insert pallet data into row
ActiveWorkbook.ActiveSheet.Cells(LRow, 1) = ActiveWorkbook.ActiveSheet.Cells(LRow - 7, 14) & ActiveWorkbook.ActiveSheet.Cells(LRow - 7, 15) & ActiveWorkbook.ActiveSheet.Cells(LRow - 7, 16) & ActiveWorkbook.ActiveSheet.Cells(LRow - 7, 17)
ActiveWorkbook.ActiveSheet.Cells(LRow, 2) = ActiveWorkbook.ActiveSheet.Cells(LRow - 6, 14)
ActiveWorkbook.ActiveSheet.Cells(LRow, 3) = ActiveWorkbook.ActiveSheet.Cells(LRow - 5, 14)
ActiveWorkbook.ActiveSheet.Cells(LRow, 4) = ActiveWorkbook.ActiveSheet.Cells(LRow - 4, 14)
ActiveWorkbook.ActiveSheet.Cells(LRow, 5) = ActiveWorkbook.ActiveSheet.Cells(LRow - 3, 14)
ActiveWorkbook.ActiveSheet.Cells(LRow, 6) = ActiveWorkbook.ActiveSheet.Cells(LRow - 2, 14) & ActiveWorkbook.ActiveSheet.Cells(LRow - 2, 15) & ActiveWorkbook.ActiveSheet.Cells(LRow - 2, 16) & ActiveWorkbook.ActiveSheet.Cells(LRow - 2, 17) & ActiveWorkbook.ActiveSheet.Cells(LRow - 2, 18)
ActiveWorkbook.ActiveSheet.Cells(LRow, 7) = ActiveWorkbook.ActiveSheet.Cells(LRow - 1, 12)
ActiveWorkbook.ActiveSheet.Cells(LRow, 8) = ActiveWorkbook.ActiveSheet.Cells(LRow - 1, 13)
ActiveWorkbook.ActiveSheet.Cells(LRow, 9) = ActiveWorkbook.ActiveSheet.Cells(LRow - 1, 14)
ActiveWorkbook.ActiveSheet.Cells(LRow, 10) = ActiveWorkbook.ActiveSheet.Cells(LRow - 1, 15)
ActiveWorkbook.ActiveSheet.Cells(LRow, 11) = ActiveWorkbook.ActiveSheet.Cells(LRow - 1, 16)
End If
End If
End If
Next LRow
'Deletes all Rows containing 1 in column K
Dim j As Long
For j = ActiveWorkbook.ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row To 1 Step -1
If ActiveWorkbook.ActiveSheet.Cells(j, 11) = 1 Then Rows(j).EntireRow.Delete
Next
'Deletes superfluous columnn
Range("M1").Select
Selection.EntireColumn.Delete
Range("A1").Select
Selection.EntireRow.Insert
'Seperates Date into day month year and pastes it correctly into date column
Range("C:C").Select
Selection.NumberFormat = "mm/dd/yyyy"
Selection.TextToColumns Destination:=Range("V1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
:="/", FieldInfo:=Array(Array(1, 1), Array(2, 1), Array(3, 1)), _
TrailingMinusNumbers:=True
j = 1
For j = ActiveWorkbook.ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row To 1 Step -1
ActiveWorkbook.ActiveSheet.Cells(j, 3) = ActiveWorkbook.ActiveSheet.Cells(j, 23).Value & "/" & ActiveWorkbook.ActiveSheet.Cells(j, 22).Value & "/" & ActiveWorkbook.ActiveSheet.Cells(j, 24).Value
Next
ActiveSheet.Columns("V:X").Delete
Range("C:C").Select
Selection.NumberFormat = "dd-mmm-yy"
'Inserts header
ActiveWorkbook.ActiveSheet.Cells(1, 1) = "Agent"
ActiveWorkbook.ActiveSheet.Cells(1, 2) = "Freight No"
ActiveWorkbook.ActiveSheet.Cells(1, 3) = "Freight Date"
ActiveWorkbook.ActiveSheet.Cells(1, 4) = "Gross Weight(kg)"
ActiveWorkbook.ActiveSheet.Cells(1, 5) = "Add hoc"
ActiveWorkbook.ActiveSheet.Cells(1, 6) = "Remark"
ActiveWorkbook.ActiveSheet.Cells(1, 7) = "Pallet No"
ActiveWorkbook.ActiveSheet.Cells(1, 8) = "ULD Type"
ActiveWorkbook.ActiveSheet.Cells(1, 9) = "T/M"
ActiveWorkbook.ActiveSheet.Cells(1, 10) = "Code"
ActiveWorkbook.ActiveSheet.Cells(1, 11) = "S/A/E"
ActiveWorkbook.ActiveSheet.Cells(1, 12) = "AWB No"
ActiveWorkbook.ActiveSheet.Cells(1, 13) = "Lwgt(kg)ABW"
ActiveWorkbook.ActiveSheet.Cells(1, 14) = "Cwgt(kg)AWB"
ActiveWorkbook.ActiveSheet.Cells(1, 15) = "Rate(kg) AWB"
ActiveWorkbook.ActiveSheet.Cells(1, 16) = "Remarks AWB"
ActiveWorkbook.ActiveSheet.Cells(1, 17) = "G Amount AWB"
ActiveWorkbook.ActiveSheet.Cells(1, 18) = "Net Amount AWB"
ActiveWorkbook.ActiveSheet.Cells(1, 19) = "Dest AWB"
ActiveWorkbook.ActiveSheet.Cells(1, 20) = "Zone AWB"
Dim LR, startDate, endDate As Long
'Name Worksheet
LR = Range("C" & Rows.Count).End(xlUp).Row
ActiveSheet.Sort.SortFields.Clear
ActiveSheet.Sort.SortFields.Add Key:=Range( _
"C2:C" & LR), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortNormal
With ActiveSheet.Sort
.SetRange Range("A2:T" & LR)
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
startDate = ActiveWorkbook.ActiveSheet.Cells(2, 3)
LR = Range("C" & Rows.Count).End(xlUp).Row
ActiveSheet.Sort.SortFields.Clear
ActiveSheet.Sort.SortFields.Add Key:=Range( _
"C2:C" & LR), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:= _
xlSortNormal
With ActiveSheet.Sort
.SetRange Range("A2:T" & LR)
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
endDate = ActiveWorkbook.ActiveSheet.Cells(2, 3)
ActiveSheet.Name = Format(startDate, "ddmmmyy") & "-" & Format(endDate, "ddmmmyy")
'Instruction to save the file
Dim Instruction2 As String
Instruction2 = "Please save the file in your desired format and location "
MsgBox Instruction2
'Save workbook in specific place and propose specific filename
Dim filename As String
'Create filename
filename = "AccountingFormInput_" & Format(startDate, "ddmmmyy") & "-" & Format(endDate, "ddmmmyy")
'Open "Save as" dialog und propose filename
Application.Dialogs(xlDialogSaveAs).Show filename
End Sub
Der fett gekennzeichnete Teil wird bei der Fehlermeldung hervorgehoben.. Ich hoffe auf Eure Hilfe! Vielen Dank :-)
P.S. Ich habe Excel 2010.
|