AW: Sorry, benutze leiber die Beispieldatei
02.02.2009 18:00:00
fcs
Hallo Joachim,
hier die Prozeduren, die die Blätter kopieren und die die Daten aus den reinkopierten Blättern in das Importblatt übertragen. Ein paar Zeilen muss du ggf. noch anpassen.
Gruß
Franz
Sub DatenImport()
Dim wbQuelle As Workbook, wksQuelle As Worksheet
Dim wbZiel As Workbook
Dim varAuswahl, strVerzeichnisAktuell
Dim intI, strPrompt As String
'Verzeichnis der Quelldatei = Startverzeichnis für Dateiauswahl
' Const strPfadQ As String = "D:\Daten" 'ggf. Anpassen!!
Const strPfadQ As String = "C:\Lokale Daten\Test" 'ggf. Anpassen!!
'Aktuelles Verzeichnis merken
strVerzeichnisAktuell = VBA.CurDir
'Startverzeichnis für Importdatei-Auswahl setzen
VBA.ChDir strPfadQ
varAuswahl = Application.GetOpenFilename(FileFilter:="Excel(*.xls),*.xls)", _
Title:="Bitte Quelldatei für Daten-Import öffnen")
If Not varAuswahl = False Then
Set wbZiel = ActiveWorkbook
'Quelldatei schreibgeschützt öffnen
Set wbQuelle = Workbooks.Open(Filename:=varAuswahl, ReadOnly:=True)
intI = -1
Application.ScreenUpdating = False
For Each wksQuelle In wbQuelle.Worksheets
If InStr(1, wksQuelle.Range("F3"), "Bestellung") > 0 Then 'Zelladresse anpassen
intI = intI + 1
With wksQuelle
.Copy After:=wbZiel.Sheets(wbZiel.Sheets.Count)
End With
End If
Next
Application.ScreenUpdating = True
If intI = -1 Then
MsgBox "In Quelldatei keine Blätter mit Eintrag ""Bestellung"" in F3 gefunden!"
Else
wbZiel.Activate
'Daten nach Importblatt übertragen
Call DatenNachImport
End If
If MsgBox("Quelldatei wieder schließen?", vbQuestion + vbYesNo, "Daten-Import") _
= vbYes Then
wbQuelle.Close savechanges:=False
End If
End If
'Verzeichnis wieder zurücksetzen
VBA.ChDir strVerzeichnisAktuell
'Datenobjekte aufräumen
Set wksQuelle = Nothing
Set wbZiel = Nothing: Set wbQuelle = Nothing
End Sub
Sub DatenNachImport()
Dim wksDaten As Worksheet, wksImport As Worksheet, wksQuelle As Worksheet
Dim lngZeileImp As Long, lngZeileQ As Long
Set wksDaten = Worksheets("Daten")
Set wksImport = Worksheets("Import")
'Startzeile für Import
With wksImport
lngZeileImp = .Cells(.Rows.Count, 1).End(xlUp).Row
End With
For Each wksQuelle In ActiveWorkbook.Worksheets
Select Case LCase(wksQuelle.Name)
Case LCase(wksDaten.Name), LCase(wksImport.Name), LCase("ImportMuster")
'do nothing
Case Else
With wksQuelle
If UCase(.Range("F10")) = "BESTELLUNG" Then '##### Zelladresse prüfen!!!
For lngZeileQ = 14 To .Cells(.Rows.Count, 1).End(xlUp).Row
If Not IsEmpty(.Cells(lngZeileQ, 1)) Then
If IsNumeric(.Cells(lngZeileQ, 1)) Then
lngZeileImp = lngZeileImp + 1
wksImport.Cells(lngZeileImp, 1).Value = .Cells(lngZeileQ, 1).Value
wksImport.Cells(lngZeileImp, 2).Value = "STRING1"
wksImport.Cells(lngZeileImp, 3).Value = .Range("B2").Value
wksImport.Cells(lngZeileImp, 4).Value = .Cells(lngZeileQ, 6).Value
wksImport.Cells(lngZeileImp, 5).Value = .Cells(lngZeileQ, 11).Value
wksImport.Cells(lngZeileImp, 6).Value = "EURO"
wksImport.Cells(lngZeileImp, 7).Value = .Range("E2").Value
' wksImport.Cells(lngZeileImp, 8).Value = "" 'bleibt leer
wksImport.Cells(lngZeileImp, 9).Value = .Cells(lngZeileQ, 12).Value
' wksImport.Cells(lngZeileImp, 10).Value = "" 'bleibt leer
' wksImport.Cells(lngZeileImp, 11).Value = "" 'bleibt leer
wksImport.Cells(lngZeileImp, 12).Value = "ORDER1"
wksImport.Cells(lngZeileImp, 13).Value = "ORDER2"
wksImport.Cells(lngZeileImp, 14).Value = "ORDER3"
wksImport.Cells(lngZeileImp, 15).Value = "ORDER4"
wksImport.Cells(lngZeileImp, 16).Value = "ORDER5"
wksImport.Cells(lngZeileImp, 17).Value = wksDaten.Range("C15").Value
' wksImport.Cells(lngZeileImp, 18).Value = "" 'bleibt leer
wksImport.Cells(lngZeileImp, 19).Value = 1 '100%
wksImport.Cells(lngZeileImp, 20).Value = "BELEG"
wksImport.Cells(lngZeileImp, 21).Value = wksDaten.Range("C17").Value
' wksImport.Cells(lngZeileImp, 22).Value = "" 'bleibt leer
Else
If UCase(Left(.Cells(lngZeileQ, 1), 6)) = "GESAMT" _
Or UCase(Left(.Cells(lngZeileQ, 1), 4)) = "TEIL" _
Or UCase(Left(.Cells(lngZeileQ, 1), 5)) = "TOTAL" Then
lngZeileImp = lngZeileImp + 1
wksImport.Cells(lngZeileImp, 1).Value = "1"
wksImport.Cells(lngZeileImp, 2).Value = "STRING1"
wksImport.Cells(lngZeileImp, 3).Value = .Range("B2").Value
.Cells(lngZeileQ, 1).Copy Destination:=wksImport.Cells(lngZeileImp, 4)
wksImport.Cells(lngZeileImp, 5).Value = .Cells(lngZeileQ, 9).Value
wksImport.Cells(lngZeileImp, 6).Value = "EURO"
wksImport.Cells(lngZeileImp, 7).Value = .Range("E2").Value
' wksImport.Cells(lngZeileImp, 8).Value = "" 'bleibt leer
wksImport.Cells(lngZeileImp, 9).Value = .Cells(lngZeileQ, 12).Value
' wksImport.Cells(lngZeileImp, 10).Value = "" 'bleibt leer
' wksImport.Cells(lngZeileImp, 11).Value = "" 'bleibt leer
wksImport.Cells(lngZeileImp, 12).Value = "ORDER1"
wksImport.Cells(lngZeileImp, 13).Value = "ORDER2"
wksImport.Cells(lngZeileImp, 14).Value = "ORDER3"
wksImport.Cells(lngZeileImp, 15).Value = "ORDER4"
wksImport.Cells(lngZeileImp, 16).Value = "ORDER5"
wksImport.Cells(lngZeileImp, 17).Value = wksDaten.Range("C15").Value
' wksImport.Cells(lngZeileImp, 18).Value = "" 'bleibt leer
wksImport.Cells(lngZeileImp, 19).Value = 1 '100%
wksImport.Cells(lngZeileImp, 20).Value = "BELEG"
wksImport.Cells(lngZeileImp, 21).Value = wksDaten.Range("C17").Value
' wksImport.Cells(lngZeileImp, 22).Value = "" 'bleibt leer
End If
End If
End If
Next
End If
End With
End Select
Next
End Sub