AW: @fcz / Franz
27.05.2014 13:19:56
fcs
Hallo Heike,
wenn die Spalten Land, KZ und Preis2 in der Ergebnisliste entfallen, dann muss das Makro etwa wie folgt aussehen.
Gruß
Franz
Sub Einlesen_Tagesdaten()
Dim varTag As Variant, wkbTag As Workbook, wksTag As Worksheet, arrData
Dim rngFind As Range, varArtikel As Variant, lngZeile As Long
Dim wksListe As Worksheet, objList As ListObject
Dim lngSpalte As Long, lngListeZ As Long, lngListeS As Long, lngSpaArtikel As Long
Dim datDatum As Date, strDatum As String, varDatum
Dim varAuswahl
Set wksListe = ActiveSheet
Set objList = wksListe.ListObjects(1)
varAuswahl = Application.GetOpenFilename(Filefilter:="Excel (*.xls;*xlsx),*.xls;xlsx", _
Title:="Bitte einzulesende Datei auswählen-Mehrfachauswahl ist möglich", _
MultiSelect:=True)
If Not IsArray(varAuswahl) Then
'do nothing
Else
'Berechnungsmodus auf manuell und Bildschirmaktualisierung abschalten
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
'ausgewählte Datei(en) abarbeiten
For Each varTag In varAuswahl
Set wkbTag = Application.Workbooks.Open(Filename:=varTag, ReadOnly:=True)
Set wksTag = wkbTag.Worksheets(1)
Application.ScreenUpdating = True
'Datum der einzulesenden Datei ggf. bestätigen
varDatum = Format(wksTag.Cells(2, 1).Value, "DD.MM.YYYY")
varDatum = VBA.InputBox("Datum der Datei?", _
Title:="Datum für Zeile 1 in Tabelle", Default:=varDatum)
Application.ScreenUpdating = False
If varDatum = "" Then
'do nothing - Eingabe wurde abgebrochen
ElseIf IsDate(varDatum) Then
'Daten der Tagesdatei in ein Array laden - beschleunigt bei Bearbeitung
With wksTag
arrData = .Range(.Cells(1, 1), .Cells(.Rows.Count, 3).End(xlUp).Offset(0, 4))
End With
datDatum = CDate(varDatum)
strDatum = Format(datDatum, "MM-DD") 'Datumsformat für Zeile 1 in Gesamtliste
'Spalte für nächstes Datum in Gesamtliste
lngSpalte = objList.Range.Column + objList.Range.Columns.Count
'Datum als Text einfügen - erforderlich für Listobject
wksListe.Cells(objList.Range.Row, lngSpalte).Value = "'" & strDatum
With wksListe
'Formel für Lief_Datum anpassen:==[@[01-14]] - Spaltenbereich
.Range(objList.Name & "[Lief_Datum]").FormulaR1C1 = _
"=[@[" & .Cells(objList.Range.Row, lngSpalte).Text & "]]"
'Spalte mit neuem Datum formatieren
With .Range(objList.Name & "[" & strDatum & "]")
.NumberFormat = "D. MMM YY"
.EntireColumn.ColumnWidth = 10
End With
'Spalte mit Artikelnummer
lngSpaArtikel = .Range(objList.Name & "[Artikel]").Column
'Zeilen der Tagestabelle abarbeiten
For lngZeile = 2 To UBound(arrData, 1)
'Land prüfen
If arrData(lngZeile, 2) = "DE" Then
'Lieferdatum prüfen
' If arrData(lngZeile, 1) "" Then
'Artikelnummer aus Tagesliste in Gesamtliste suchen
varArtikel = arrData(lngZeile, 3)
Set rngFind = .Range(objList.Name & "[Artikel]").Find(what:=varArtikel, LookIn:= _
xlValues, _
lookat:=xlWhole)
If rngFind Is Nothing Then
'nächste freie Zeile in Artikelspalte ermitteln
lngListeZ = .Cells(.Rows.Count, lngSpaArtikel).End(xlUp).Row
If .Cells(lngListeZ, lngSpaArtikel) "" Then
lngListeZ = lngListeZ + 1
End If
'neuen Artikel an Liste anfügen
For lngListeS = 1 To 6 'Spalten in Tagesdatei abarbeiten
Select Case lngListeS
Case 1 'Spalte A - Datum
.Cells(lngListeZ, 1).Value = arrData(lngZeile, lngListeS)
Case 3 'Spalte C - Artikel
.Cells(lngListeZ, 2).Value = arrData(lngZeile, lngListeS)
Case 5 'Spalte E - Preis1
.Cells(lngListeZ, 3).Value = arrData(lngZeile, lngListeS)
Case Else
'do nothing
End Select
Next
Else
lngListeZ = rngFind.Row
End If
.Cells(lngListeZ, lngSpalte).Value = arrData(lngZeile, 1) 'Lieferdatum
End If
' End If
Next
End With
Erase arrData 'Daten-Array leeren
Else
MsgBox "unzulässige Eingabe für ein Datum!"
End If
'Tagesliste ohne speichern wieder schließen
wkbTag.Close savechanges:=False
Set wkbTag = Nothing
Set wksTag = Nothing
Next
Set objList = Nothing
Set wksListe = Nothing
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End If
End Sub