ich habe eine Datei bei der die Bestellungen für einen Tag zusammengezählt werden
Bislang funkioniert alles wunderbar.
Nur wenn die Bestellnummern nicht nur aus Zahlen sondern aus einer Kombination von Buchstaben und Zahlen sind kommt der Fehler 13.
Leider finde ich den Fehler nicht.
Auf "Tagesbestellung zusammenfassen klicken"
Gruß Tobi
Abei die Datei und das Makro
https://www.herber.de/bbs/user/89811.zip
Sub Bestellung()
Dim oWorkbook As Workbook
Dim wksDaten As Worksheet
Dim wksBestell As Worksheet
Dim wksEingabe As Worksheet
Dim ZeileZ As Long, Zelle As Range
Dim lngZeileD As Long, lngSpalteD As Long
Dim Zeile_D As Long, Spalte_D As Long
Dim objCol As New Collection
Dim datDatum As Date
Dim arrBestell() As Variant, intJ As Integer, intK As Integer
Dim varArtNr, varMenge
Const cZeileTitel As Long = 4 'Zeile mit Spaltentiteln in Bestellliste
UserForm1.Show vbModeless
Application.Wait Now + TimeValue("00:00:01")
On Error GoTo Fehler
Set wksBestell = ThisWorkbook.Worksheets("Tages Verkauf")
Set wksEingabe = ThisWorkbook.Worksheets("Eingabe")
datDatum = wksEingabe.Range("B4")
wksBestell.Range("D2") = datDatum
' Prüfen ob Datei "Daten.xls" geöffnet ist
With Application
For Each oWorkbook In .Workbooks
If UCase$(oWorkbook.Name) = UCase(pcDateiDaten) Then
Exit For
End If
Next
End With
If oWorkbook Is Nothing Then
MsgBox "Die Datei """ & pcDateiDaten & """ ist nicht geöffnet!"
Exit Sub
End If
Set wksDaten = oWorkbook.Worksheets("Daten")
'Alt-Daten in Bestellungen löschen
With wksBestell
Set Zelle = .Range("B:D").Find(what:="*", after:=.Cells(1, 2), LookIn:=xlFormulas, _
lookat:=xlWhole, searchorder:=xlByRows, searchdirection:=xlPrevious)
ZeileZ = cZeileTitel 'Zeile mit Spaltentiteln
If Zelle Is Nothing Then
Else
If Zelle.Row > ZeileZ Then
.Range(.Rows(ZeileZ + 1), .Rows(Zelle.Row)).ClearContents
End If
End If
End With
'suchen nach den Zeilen mit dem Datum für die Bestellungen
With wksDaten
For Zeile_D = 2 To .Cells(.Rows.Count, 1).End(xlUp).Row
If .Cells(Zeile_D, 3).Value = datDatum Then
' Daten in der Zeile ab Spalte 4 in Blatt "Eingang" ab Zeile 14 eintragen
For lngSpalteD = 4 To .Cells(Zeile_D, .Columns.Count).End(xlToLeft).Column Step 4
With .Cells(Zeile_D, lngSpalteD)
varArtNr = .Offset(0, 1) 'Artikelnr
If varArtNr "" Then
varMenge = .Value 'Menge
objCol.Add Item:=varArtNr, Key:=Str(varArtNr)
' Zeilenzähler im Artikel erhöhen
intJ = intJ + 1
ReDim Preserve arrBestell(1 To 2, 1 To intJ)
arrBestell(1, intJ) = varArtNr
arrBestell(2, intJ) = varMenge
End If
End With
NextArtikel:
Next lngSpalteD
End If
Next Zeile_D
End With 'wksDaten
If intJ > 0 Then
With wksBestell
For intK = 1 To intJ
ZeileZ = ZeileZ + 1
.Cells(ZeileZ, 2) = intK
.Cells(ZeileZ, 3) = arrBestell(1, intK)
.Cells(ZeileZ, 4) = arrBestell(2, intK)
Next intK
If ZeileZ > cZeileTitel + 1 Then
'Daten nach Artikel-Nr. sortieren
With .Range(.Cells(cZeileTitel, 3), .Cells(ZeileZ, 4))
.Sort Key1:=.Cells(1, 1), Order1:=xlAscending, Header:=True
End With
End If
'Formel für Bezeichnung und Gewicht einfügen und Ergebnisse durch Werte ersetzen
With .Range(.Cells(cZeileTitel + 1, 6), .Cells(ZeileZ, 6))
'Bezeichnung einfügen und Ergebnisse durch Werte ersetzen
.FormulaR1C1 = "=IF(ISERROR(VLOOKUP(RC[-3],Artikel!C2:C9,2,0)),""nicht vorhanden""," _
_
_
& "VLOOKUP(RC[-3],Artikel!C2:C9,2,0))"
.Calculate
.Value = .Value
'Gewicht einfügen und Ergebnisse durch Werte ersetzen
.Offset(0, 1).FormulaR1C1 = "=IF(ISERROR(VLOOKUP(RC[-4],Artikel!C2:C9,3,0))," _
& """nicht vorhanden"",IF(VLOOKUP(RC[-4],Artikel!C2:C9,3,0)="""",""""," _
& "VLOOKUP(RC[-4],Artikel!C2:C9,3,0)))"
.Offset(0, 1).Calculate
.Offset(0, 1).Value = .Offset(0, 1).Value
'Lieferant einfügen und Ergebnisse durch Werte ersetzen
.Offset(0, 2).FormulaR1C1 = "=VLOOKUP(RC[-5],Artikel!R2C2:R2000C5,4,1)"
.Offset(0, 2).Calculate
.Offset(0, 2).Value = .Offset(0, 2).Value
End With
End With
Else
MsgBox "keine Bestellungen zum Datum " & Format(datDatum, "DD.MM.YYYY") & " gefunden!"
End If
Fehler:
With Err
Select Case .Number
Case 0
Case 457 'Fehler - Artikelnummer kommt mehrfach vor
'Artikel-Nr. in Liste suchen und Menge addieren
For intK = 1 To UBound(arrBestell, 2)
If arrBestell(1, intK) = varArtNr Then
arrBestell(2, intK) = arrBestell(2, intK) + varMenge
Exit For
End If
Next
Resume NextArtikel
Case Else
MsgBox "Fehler-Nr.: " & .Number & vbLf & .Description
End Select
End With
UserForm1.Hide
End Sub