Schick mal Code
01.11.2007 19:26:00
Walter
Hallo Jens,
anbei der Code, läuft einwandfrei wenn ich dies von der Tabellen-Oberfläche aus starte.
Da ich nicht weiß welche Datei mit UF versehen ist kann ich da ja nichts ändern.
Hier ist der Code, den hat mir freundlicherweise Peter Feustel erstellt, ein Profi, ist auch immer
im Forum.
Public Sub Daten_holen_III()
Dim DatName As String ' Pfad und Name der ausgewählten Mappe
Dim WkBk_Quelle As Workbook ' das Herkunfts-Workbook - die Quelle
Dim WkSh_Q As Worksheet ' zur bequemeren Schreibweise
Dim iBlatt_Q As Integer ' For/Next Index der Tabellenblätter der Quelldatei
Dim lZeile_Q As Long ' For/Next Zeilen-Index zum Verkäufer auslesen
Dim WkBk_Ziel As Workbook ' das Empfangs-Workbook - das Ziel
Dim iBlatt_Z As Integer ' For/Next Index der Tabellenblätter der Zieldatei
Dim aVerkaeufer() As Variant ' ein Array der Verkäufer-Namen
Dim iArrIndx As Integer ' der Index zum Array
Dim iGefunden As Integer ' der Schalter ob alle Tabellenblätter vorhanden sind
' hier kann die zu kopierende Datei ausgewählt werden.
ChDir "C:\"
DatName = Application.GetOpenFilename("Microsoft Excel-Dateien ( (*.xls), *.xls", , _
" Bitte die erforderliche Excel-Mappe auswählen.")
If DatName = "" Or DatName = "Falsch" Then
MsgBox "Sie haben keine Datei ausgewählt => Abbruch!", _
48, " Hinweis für " & Application.UserName
Exit Sub
End If
Application.ScreenUpdating = False ' den Bildschirm-Update unterdrücken
Set WkBk_Ziel = ActiveWorkbook ' diese Datei ist das Ziel !!!
Set WkSh_Q = Worksheets("Eingabe")
For lZeile_Q = 10 To WkSh_Q.Cells(Rows.Count, 133).End(xlUp).Row
If WkSh_Q.Cells(lZeile_Q, 133).Value "" Then
iArrIndx = iArrIndx + 1
ReDim Preserve aVerkaeufer(iArrIndx)
aVerkaeufer(iArrIndx) = Trim(WkSh_Q.Cells(lZeile_Q, 133).Value)
End If
Next lZeile_Q
' ' diese Datei ist die Quelle !!!
Set WkBk_Quelle = Workbooks.Open(Filename:=(DatName), ReadOnly:=True)
' alle Blätter gemäß Verkäufer-Array bearbeiten
For iArrIndx = 1 To UBound(aVerkaeufer)
iGefunden = 0
For iBlatt_Z = 1 To WkBk_Ziel.Sheets.Count
If WkBk_Ziel.Sheets(iBlatt_Z).Name = aVerkaeufer(iArrIndx) Then
iGefunden = iGefunden + 1
Exit For
End If
Next iBlatt_Z
For iBlatt_Q = 1 To WkBk_Quelle.Sheets.Count
If WkBk_Quelle.Sheets(iBlatt_Q).Name = aVerkaeufer(iArrIndx) Then
iGefunden = iGefunden + 1
Exit For
End If
Next iBlatt_Q
If iGefunden = 2 Then
WkBk_Quelle.Sheets(aVerkaeufer(iArrIndx)).Range("G20:H33").Copy Destination:= _
WkBk_Ziel.Sheets(aVerkaeufer(iArrIndx)).Range("G20")
Else
MsgBox "Zum Verkäufer """ & aVerkaeufer(iArrIndx) & """ wurde entweder" & _
Chr(10) & "in der Ziel- oder in der Quell-Mappe kein passendes" & Chr(10) & _
"Tabellenblatt gefunden.", 48, " Hinweis für " & Application.UserName
End If
Next iArrIndx ' das nächste Tabellenblatt holen
Application.CutCopyMode = False ' Copy-Mode zurücksetzten
WkBk_Quelle.Close SaveChanges:=False ' die Quell-Datei wieder schließen
Application.ScreenUpdating = True ' den Bildschirm-Update wieder zulassen
End Sub