VBA-Forum - Das Forum zu Microsoft VBA

VBA Excel VBA Word VBA Access VBA VBScript VB C# Objective-C C++ SQL JAVA VBA (English) Jobs Übersicht

Thema	Datum	Von Nutzer	Rating	Antwort
Run Time Error 13 - Type mismatch	19.11.2015 02:02:29	Nina

Ansicht des Beitrags:

Von:
Nina

Datum:
19.11.2015 02:02:29

Views:
1053

Rating:

Antwort:

Thema:
Run Time Error 13 - Type mismatch

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.

Ihre Antwort

Bitte beschreiben Sie Ihr Problem möglichst ausführlich. (Wichtige Info z.B.: Office Version, Betriebssystem, Wo genau kommen Sie nicht weiter)
Bitte helfen Sie ebenfalls wenn Ihnen geholfen werden konnte und markieren Sie Ihre Anfrage als erledigt (Klick auf Häckchen)
Bei Crossposting, entsprechende Links auf andere Forenbeiträge beifügen / nachtragen
Codeschnipsel am besten über den Code-Button im Text-Editor einfügen
Die Angabe der Emailadresse ist freiwillig und wird nur verwendet, um Sie bei Antworten auf Ihren Beitrag zu benachrichtigen

Thema:		Name:		Email:

Bitte beschreiben Sie Ihr Problem möglichst ausführlich. (Wichtige Info z.B.: Office Version, Betriebssystem, Wo genau kommen Sie nicht weiter)
Bitte helfen Sie ebenfalls wenn Ihnen geholfen werden konnte und markieren Sie Ihre Anfrage als erledigt (Klick auf Häckchen)
Bei Crossposting, entsprechende Links auf andere Forenbeiträge beifügen / nachtragen
Codeschnipsel am besten über den Code-Button im Text-Editor einfügen
Die Angabe der Emailadresse ist freiwillig und wird nur verwendet, um Sie bei Antworten auf Ihren Beitrag zu benachrichtigen

Thema	Datum	Von Nutzer	Rating	Antwort
Run Time Error 13 - Type mismatch	19.11.2015 02:02:29	Nina