Sub Importiere()
Dim myRec As String, strKdNr As String 'geändert
'Quelle wählen
If Not Dateiabfrage Then Exit Sub
'anhängen oder überschreiben
If Not BeginnMit Then Exit Sub
Gesamtes Makro:
Option Explicit
'die Excel Tabelle ist formatiert (Spaltenbreiten, Datenformat etc)
'Voreinstellungen - ggf. anpassen
Const TName As String = "Tabelle1" 'Tabellenblattname wo/wegen Werte sortieren
Const DtmSp As Long = 2 'Spalte Nr. für Datum
Const SndSp As Long = 3 ' Sendung
Const Bg1Sp As Long = 4 ' Beleg1
Const Bg2Sp As Long = 5 '
Const Bg3Sp As Long = 6 '
Const FpSSp As Long = 7 ' Flachpalette Soll
Const FpHSp As Long = 8 ' Haben
Const GpSSp As Long = 9 ' Gitterpalette
Const GpHSp As Long = 10
Const KdNrSp As Long = 11 'Neu Tour/Kunden-Nummer
Const aDtmSp As Long = 12 'Spalte Nr.für Datum - Auswertung
Const aSndSp As Long = 13 ' Sendung (aha Rollkarte)
Const aFpSSp As Long = 14 ' Flachpalette Soll
Const aFpHSp As Long = 15 ' Haben
Const aGpSSp As Long = 16 ' Gitterpalette Soll
Const aGpHSp As Long = 17 ' Habben
Const aKdNrSp As Long = 18 'Kunden-Nr 'neu fcs 2015-03-22
'Datensatzaufbau lt. Mustertext - Anpassung ab 2015-02
Const Nx1Lg As Integer = 2 ' alt 4 'Länge Zeichenkette für Nix
Const DtmLg As Integer = 10 'Datum
Const SndLg As Integer = 9 'Sendung
Const Bg1Lg As Integer = 27 'Beleg1
Const Bg2Lg As Integer = 9 ' alt 10 '
Const Bg3Lg As Integer = 10 '
Const Nx2Lg As Integer = 1 '* - Nix
Const FpSLg As Integer = 8 ' 'Flachpalette Soll
Const FpHLg As Integer = 9 'alt 10 ' Haben
Const Nx3Lg As Integer = 1 'alt 6 '* - Nix
Const GpSLg As Integer = 8 'alt 6 'Gitterpalette Soll
Const GpHLg As Integer = 9 'alt10 ' Haben
Const Nx4Lg As Integer = 1 'neu '* - Nix - neue Spalten mit Soll/Haben
Const UbSLg As Integer = 8 'neu 'Unbekannt Soll
Const UbHLg As Integer = 9 'neu 'Unbekannt Haben
'Variable
Dim txtFile As String 'Import Quelle
Dim AbZeile As Long 'Import ab Tabellenzeile - 2 Zeilen Überschrift _
_
Dim aAbZeile As Long 'Auswertung ab Tabellenzeile
Sub Importiere()
Dim myRec As String, strKdNr As String 'geändert
'Quelle wählen
If Not Dateiabfrage Then Exit Sub
'anhängen oder überschreiben
If Not BeginnMit Then Exit Sub
'Startzeile merken
aAbZeile = AbZeile
'sequentiell einlesen
Application.ScreenUpdating = False
Open txtFile For Input As #1
Do While Not EOF(1)
Line Input #1, myRec
Debug.Print myRec
'Kundennummer/Tour ermitteln
If InStr(1, myRec, "Kunden-Nummer ") > 0 Then 'neu-geändert
strKdNr = Mid(myRec, InStr(1, myRec, "Kunden-Nummer ") + 14)
End If
If SollIch(myRec) Then
myRec = SatzKappen(myRec, Nx1Lg)
Cells(AbZeile, DtmSp).Value = CDate(Trim(Left(myRec, DtmLg)))
myRec = SatzKappen(myRec, DtmLg)
Cells(AbZeile, SndSp).Value = Trim(Left(myRec, SndLg))
myRec = SatzKappen(myRec, SndLg)
Cells(AbZeile, Bg1Sp).Value = Trim(Left(myRec, Bg1Lg))
myRec = SatzKappen(myRec, Bg1Lg)
Cells(AbZeile, Bg2Sp).Value = Trim(Left(myRec, Bg2Lg))
myRec = SatzKappen(myRec, Bg2Lg)
Cells(AbZeile, Bg3Sp).Value = Trim(Left(myRec, Bg3Lg))
myRec = SatzKappen(myRec, Bg3Lg)
myRec = SatzKappen(myRec, Nx2Lg)
'von wegen kein Eintrag - Flachpaletten-Daten
On Error Resume Next
Cells(AbZeile, FpSSp).Value = CDbl(Trim(Left(myRec, FpSLg)))
myRec = SatzKappen(myRec, FpSLg)
Cells(AbZeile, FpHSp).Value = CDbl(Trim(Left(myRec, FpHLg)))
myRec = SatzKappen(myRec, FpHLg)
On Error GoTo 0
myRec = SatzKappen(myRec, Nx3Lg)
'von wegen kein Eintrag - Gitterpaletten-Daten
On Error Resume Next
Cells(AbZeile, GpSSp).Value = CDbl(Trim(Left(myRec, GpSLg)))
myRec = SatzKappen(myRec, GpSLg)
Cells(AbZeile, GpHSp).Value = CDbl(Trim(Left(myRec, GpHLg)))
myRec = SatzKappen(myRec, GpHLg)
On Error GoTo 0
myRec = SatzKappen(myRec, Nx4Lg)
'von wegen kein Eintrag - unbekante Sache
On Error Resume Next
Cells(AbZeile, UbSSp).Value = CDbl(Trim(Left(myRec, UbSLg)))
myRec = SatzKappen(myRec, UbSLg)
Cells(AbZeile, UbHSp).Value = CDbl(Trim(Left(myRec, UbHLg)))
Cells(AbZeile, KdNrSp).Value = strKdNr
On Error GoTo 0
Rahmen rum
Call Umrahmen(0)
AbZeile = AbZeile + 1
End If
Loop
Close #1
'Spalten DtmSp - SndSp u. FpSSp - GpHSp zur Auswertung kopieren
Range(Cells(aAbZeile, DtmSp), Cells(AbZeile, SndSp)).Copy _
Destination:=Cells(aAbZeile, aDtmSp)
Range(Cells(aAbZeile, FpSSp), Cells(AbZeile, KdNrSp)).Copy _
Destination:=Cells(aAbZeile, aFpSSp) 'geändert fcs 2015-03-22
'Auswerten
'vor Auswertung sortieren nach aSndSp (einf. Makroaufzeichnung)
If Not aSortieren Then GoTo Unfertig
'zusammenschreiben
If Not Cumulus Then GoTo Unfertig
'nochmals sortieren
If Not aSortieren Then GoTo Unfertig
'ggf. alte Reste weg
AbZeile = AbZeile + 1
Range(Cells(AbZeile, DtmSp), Cells(mylastRow, aKdNrSp)).Clear 'geändert fcs 2015-03-22
Application.ScreenUpdating = True
Cells(aAbZeile, aDtmSp).Select
Exit Sub
Unfertig:
Application.ScreenUpdating = True
MsgBox "Es sind Fehler aufgetreten"
End Sub
'
'
Function Cumulus() As Boolean
Dim y As Integer
On Error GoTo errorhandler
'von unten nach oben
AbZeile = AbZeile - 1
Cells(AbZeile, aSndSp).Select
Do While ActiveCell.Row > aAbZeile
'solange Wert davor gleich
Do While ActiveCell.Offset(-1, 0).Value = ActiveCell.Value
ActiveCell.Offset(-1, 0).Select
For y = 1 To 4
ActiveCell.Offset(0, y).Value = _
ActiveCell.Offset(0, y).Value + _
ActiveCell.Offset(1, y).Value
Next y
With Range(ActiveCell.Offset(1, -1), ActiveCell.Offset(1, 5)) 'geändert fcs 2015-03-22
.Value = ""
'.Borders.LineStyle = xlLineStyleNone
End With
Loop
'einfärben
Call Einfärben(0)
'1 nach oben
ActiveCell.Offset(-1, 0).Select
Loop
'letze Zeile
Call Einfärben(0)
Cumulus = True
Exit Function
errorhandler:
MsgBox "Abbruch - Fehler in Cumulus"
End Function
'
Sub Einfärben(dummy)
Range(ActiveCell.Offset(0, 1), ActiveCell.Offset(0, 5)).Interior.ColorIndex = 35 'geändert fcs _
_
2015-03-22
If ActiveCell.Offset(0, 1).Value ActiveCell.Offset(0, 2).Value Then _
Range(ActiveCell.Offset(0, 1), ActiveCell.Offset(0, 2)).Interior.ColorIndex = 40
If ActiveCell.Offset(0, 3).Value ActiveCell.Offset(0, 4).Value Then _
Range(ActiveCell.Offset(0, 3), ActiveCell.Offset(0, 5)).Interior.ColorIndex = 40 'geä _
ndert fcs 2015-03-22
End Sub
'
Function aSortieren() As Boolean
On Error GoTo errorhandler
'Excel 2000
Range(Cells(aAbZeile, aDtmSp), Cells(AbZeile, aKdNrSp)).Select 'geändert fcs 2015-03-22
Selection.Sort Key1:=Cells(AbZeile, aSndSp), _
Order1:=xlAscending, Header:=xlNo, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom 'geändert fcs 2015-03-22
aSortieren = True
Exit Function
errorhandler:
MsgBox "Abbruch - Fehler in aSortieren"
End Function
