AW: Makro-Anpassung für Spaltensortierung
24.10.2013 11:28:37
fcs
Hallo Georg,
hier der 1. Teil des Hauptmakros.
Die zu ändernden/neuen Zeilen sind gekennzeichnet.
mfg
Franz
Sub TxtLesen_Georg()
Dim arrFiles(1 To 9999) As String, lngF As Long, ii As Long
Dim anzeige As String, strVz As String, strVzout As String, strFile As String, _
strFirma As String
Dim wbkTXT As Workbook, wbkXLS As Workbook
Dim wksTXT As Worksheet, wksXLS As Worksheet
Dim lngA As Long, lngZ As Long, lngZeile As Long, lngSpaDatum As Long
Dim anzahl As Long, bewanzahl As Long, verkaufanzahl As Long
Dim varDatum As Variant, varSpalte As Variant, varFiliale As Variant
Dim rngFiliale As Range
Dim bolSort As Boolean, bolSortColumns As Boolean 'FCS geändert
Application.ScreenUpdating = False
strVz = Range("E9").Value 'Verzeichnis mit den TXT-Dateien
strVzout = Range("E12").Value 'Verzeichnis mit den XLS-Bestands-Dateien
'Zähler auf Startwerte setzen - bei 0 nicht unbedengt nötig, da numerische _
deklarierte Variablen den Standardwert 0 haben
lngF = 0
anzahl = 0
bewanzahl = 0
verkaufanzahl = 0
' Liste der Textdateien in Datenarray einlesen
arrFiles(1) = Dir(strVz & "BESTAND_*.txt")
Do While arrFiles(lngF + 1) ""
lngF = lngF + 1
arrFiles(lngF + 1) = Dir
Loop
' Abarbeiten der Datei-Liste
For ii = 1 To lngF
Application.StatusBar = "Datei " & Format(ii, "000") & " von " _
& Format(lngF, "000") & " wird bearbeitet"
' Öffnen der Textdatei
Workbooks.OpenText Filename:=strVz & arrFiles(ii), Origin:=xlWindows, _
DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, Other:=True, _
OtherChar:="|", FieldInfo:=Array(Array(1, 2), Array(2, 2), Array(3, 2), _
Array(4, 2), Array(5, 2), Array(6, 2), Array(7, 2), _
Array(8, 1), Array(9, 2), Array(10, 2))
Set wbkTXT = ActiveWorkbook
Set wksTXT = wbkTXT.Worksheets(1)
With wksTXT
lngZ = .Cells(.Rows.Count, 1).End(xlUp).Row ' Anzahl Zeilen in Textdatei
strFile = strVzout & "BESTAND_" & .Cells(2, 10).Text _
& "_ARTIKEL " & .Cells(2, 1).Text & ".xls"
End With 'wksTXT
If Dir(strFile) "" Then
' Excelmappe existiert bereits
Set wbkXLS = Workbooks.Open(strFile) 'Bestandsdatei öffnen
Set wksXLS = wbkXLS.Worksheets(1)
bolSortColumns = False 'FCS neu
bolSort = False 'FCS neu
With wksXLS
' Anzahl bestehende Zeilen in Bestandsdatei in Spalte "Filiale"
lngA = .Cells(.Rows.Count, 7).End(xlUp).Row
'Datum aus Textdatei in Bestandsdatei in Zeile 7 suchen
varDatum = CDate(wksTXT.Cells(2, 9).Text)
varSpalte = Application.Match(CLng(varDatum), .Rows(7), 0)
If IsError(varSpalte) Then
'neues Datum
lngSpaDatum = .Cells(7, .Columns.Count).End(xlToLeft).Column + 1
Call prcDatumFormat(Bereich:=.Cells(7, lngSpaDatum))
.Cells(7, lngSpaDatum).Value = varDatum
bolSortColumns = True 'FCS neu
Else
'Datum schon vorhanden
lngSpaDatum = varSpalte
End If
'Daten in Textdatei zeilenweise abarbeiten - Filialen suchen und Werte eintragen
For lngZeile = 2 To lngZ
varFiliale = wksTXT.Cells(lngZeile, 7).Value
'Filiale in Spalte G der Bestandsdatei suchen
Set rngFiliale = .Range(.Cells(8, 7), .Cells(lngA, 7)).Find(What:=varFiliale, _
LookIn:=xlValues, lookat:=xlWhole)
If rngFiliale Is Nothing Then
'Filiale ist neu
lngA = lngA + 1
'Spalten A bis G kopieren
wksTXT.Range(wksTXT.Cells(lngZeile, 1), wksTXT.Cells(lngZeile, 7)).Copy _
Destination:=.Cells(lngA, 1)
'Bestand in Datumspalte eintragen
.Cells(lngA, lngSpaDatum).Value = wksTXT.Cells(lngZeile, 8).Value
bolSort = True 'Merker, dass Daten sortiert werden müssen
Else
'Bestand in Datumspalte eintragen
.Cells(rngFiliale.Row, lngSpaDatum).Value = wksTXT.Cells(lngZeile, 8).Value
End If
Next
'ggf. Zeilen neu sortieren nach Filialen (Spalte G)
If bolSort Then
With .Range(.Rows(7), .Rows(lngA))
.Sort Key1:=.Cells(1, 7), Order1:=xlAscending, Header:=xlYes, _
Orientation:=xlSortColumns 'FCS geändert
End With
End If
'Breite der bearbeiten/angefügten Datumsspalte optimal setzen
.Columns(lngSpaDatum).AutoFit
'FCS neu - Start
'ggf. Spalten im Datenbereich nach Datum in Zeile 7 Sortieren
If bolSortColumns = True Then
varSpalte = .Cells(7, .Columns.Count).End(xlToLeft).Column
With .Range(.Cells(7, 8), .Cells(lngA, varSpalte))
.Sort Key1:=.Rows(1), Order1:=xlAscending, Header:=xlNo, _
Orientation:=xlSortRows
.EntireColumn.AutoFit
End With
End If
'FCS neu - Ende
End With 'wksXLS
wbkXLS.Close True ' Sichere und schließe Excelmappe
wbkTXT.Close False ' Schließe Textdatei ohne Sichern
Set wksTXT = Nothing: Set wbkTXT = Nothing
Set wksXLS = Nothing: Set wbkXLS = Nothing
Else