Bestehendes Makro leicht erweitern
01.03.2013 10:54:58
Pascal
Ich brauche (und hoffe) wieder einmal mehr auf Eure rasche und gute Hilfe.
ich habe hinter einer Schaltfläche den untenstehenden Makro - Code.
Dieser kopiert mir ab einem Verzeichnis in C:\temp Daten aus den XLS-Dateien, die in diesem Verzeichnis abgelegt sind.
Soweit so gut !
In jedem dieser Datei steht in der Zeile 8 in Spalte B eine Nummer und in Spalte C ein Text.
Ich möchte nun meinen untenstehenden Code so anpassen / erweitern, dass mir das Makro diese beiden Werte nun auch noch aus jedem File ausliest und ins Tabellenblatt "Artikelliste" schreibt.
Leider aber schlugen bisher meine Versuche das umzusetzen fehl.
Bestimmt kann mir jemand von Euch helfen und sagen, wo genau ich was in meinem Code anpassen / ändern muss, damit mir pro Zeile diese beiden Werte auch reingeschrieben werden ?
Hoffe, meine Frage sei so verständlich
besten Dank schon mal für eure Hilfe !
Anbei mein bestehender Code:
Sub Hole_Nummern_aus_Dateien()
'Variablen-Deklaration
Dim varVerzeichnis As Variant
Dim strDatei As Variant
Dim wksZiel As Worksheet
Dim wbkQuelle As Workbook, wksQuelle As Worksheet
Dim Zeile_Z As Long
Dim Zeile_Q As Long, Zeile_Q1 As Long, Zeile_Q2 As Long
Dim icount As Integer
'Dialogfenster wird eingeblendet. User wählt Pfad der kopierten Temporären Dateien aus
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Bitte Verzeichnis mit den Quell-Dateien auswählen"
.AllowMultiSelect = False
.InitialFileName = "C:\Temp"
If .Show = -1 Then
varVerzeichnis = .SelectedItems(1)
Else
Exit Sub
End If
End With
Set wksZiel = ActiveWorkbook.Sheets("Artikelnummern") 'Tabelle in welche nun die Nummern _
eingetragen werden sollen
With wksZiel
'letzte Zeile mit Dateneintrag in Spalte A der Zieltabelle
Zeile_Z = .Cells(.Rows.Count, 1).End(xlUp).Row
End With
'Excel-Dateien im oben ausgewählten Verzeichnis suchen (hierhin wurden die Temporären Dateien _
kopiert)
'--------------------------------------------------------------------------------------------- _
strDatei = Dir(varVerzeichnis & "\*.xls*")
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Do Until strDatei = ""
icount = icount + 1
Application.StatusBar = "Datei-Nr. " & icount & " - " & strDatei
'QuellDatei schreibgeschützt öffnen und gleichzeitig verhindern dass im File Verknüpfungen _
aktualisiert werden.
'------------------------------------------------------------------------------------------- _
Set wbkQuelle = Application.Workbooks.Open( _
FileName:=varVerzeichnis & "\" & strDatei, _
UpdateLinks:=3, _
ReadOnly:=True)
'Prüfen, ob Tabellenblatt "Artikelliste" in Quelldatei vorhanden
If fncCheckSheet(varBlatt:="Artikelliste", wb:=wbkQuelle) = False Then
Zeile_Z = Zeile_Z + 1
wksZiel.Cells(Zeile_Z, 1).Value = "Fehler: Blatt ""Artikelliste"" fehlt in Datei " & _
wbkQuelle.Name
Else
Set wksQuelle = wbkQuelle.Worksheets("Artikelliste")
With wksQuelle
'letzte Zeile in Spalte A = letzte Zeile mit einer Nummer
Zeile_Q2 = .Cells(.Rows.Count, 1).End(xlUp).Row
'Prüfen, ob Eintrag in letzter Zeile von Spalte mit einer Ziffer beginnt
If Not IsNumeric(Left(Trim(.Cells(Zeile_Q2, 1).Text), 1)) Then
Zeile_Z = Zeile_Z + 1
wksZiel.Cells(Zeile_Z, 1).Value = "Fehler: Keine Artikel in Datei " & wbkQuelle.Name
Else
'1. Zeile mit einer Nummer ermitteln
Zeile_Q1 = Zeile_Q2
Zeile_Q = Zeile_Q1
'Zeilen rückwärts zählen und prüfen, ob Wert in Zelle in Spalte A mit Ziffer beginnt
Do While IsNumeric(Left(Trim(.Cells(Zeile_Q, 1).Text), 1))
If Zeile_Q = 1 Then
Zeile_Q1 = 1
Exit Do
Else
Zeile_Q1 = Zeile_Q
End If
Zeile_Q = Zeile_Q - 1
Loop
'Nummern in Zieltabelle übertragen
For Zeile_Q = Zeile_Q1 To Zeile_Q2
Zeile_Z = Zeile_Z + 1
wksZiel.Cells(Zeile_Z, 1).Value = .Cells(Zeile_Q, 1).Value
wksZiel.Cells(Zeile_Z, 2).Value = .Cells(Zeile_Q, 2).Value
wksZiel.Cells(Zeile_Z, 3).Value = .Cells(Zeile_Q, 3).Value
wksZiel.Cells(Zeile_Z, 4).Value = .Cells(Zeile_Q, 4).Value
wksZiel.Cells(Zeile_Z, 5).Value = .Cells(Zeile_Q, 5).Value
Next
End If
End With
End If
'Quelldatei wieder schliessen
wbkQuelle.Close savechanges:=False
Set wbkQuelle = Nothing
Set wksQuelle = Nothing
'Nächste Datei suchen
strDatei = Dir
Loop
With Application
.StatusBar = False
.ScreenUpdating = True
.EnableEvents = True
End With
Set wksZiel = Nothing
MsgBox "Auslesen der Daten abgeschlossen"
End Sub