AW: Stapelverarbeitung
29.08.2013 14:04:11
fcs
Hallo Dani,
die Ergänzung/Anpassung deines Makros muss etwa wie folgt aussehen um die in die Zellen eingetragenen Infos in dein Tabellenblatt zu übertragen.
Gruß
Franz
Sub GetAllUpdates()
On Error GoTo hell
Dim lLastRow As Long
Dim lFirstRow As Long
Dim lFileToOpen As Long
Dim wkbOld As Workbook
Dim wkbNew As Workbook
Dim sPath As String
Dim sFile As String
Dim iErrNum As Integer
Dim wksZiel As Worksheet
Dim lZeileZiel As Long
lFirstRow = 6
'Zielblatt für Adressen initialisieren
Set wksZiel = Tabelle1
With wksZiel
'letzte Zeile in Zieltabelle mit Daten
lZeileZiel = .Cells.Find(what:="*", after:=.Cells(1, 1), LookIn:=xlFormulas, _
lookat:=xlWhole, searchorder:=xlByRows, searchdirection:=xlPrevious).Row
End With
With Sheet1
Set wkbOld = ActiveWorkbook
lLastRow = .Cells(Rows.Count, 4).End(xlUp).Row
.Range(.Cells(lFirstRow, 12), .Cells(lLastRow, 12)).ClearContents
GetMoreSpeed (True)
For lFileToOpen = lFirstRow To lLastRow
iErrNum = 0
sFile = .Cells(lFileToOpen, 6).Value
sPath = .Cells(lFileToOpen, 4).Value & "\" & sFile
UserForm_GetFiles.Label_File.Caption = sFile
UserForm_GetFiles.Label_Now.Caption = "opening file"
UserForm_GetFiles.Repaint
If WkbExists(sFile) = False Then
iErrNum = 2 'will goto OnError handler if path is wrong
If Dir(sPath) = "" Then
.Cells(lFileToOpen, 12).Value = "Workbook does not exist! Check folder and file."
GoTo skipThis
Else
Workbooks.Open sPath, UpdateLinks:=False
End If
Else
Workbooks(sFile).Activate
End If
UserForm_GetFiles.Label_Now.Caption = "check worksheet existence"
UserForm_GetFiles.Repaint
Set wkbNew = ActiveWorkbook
If Not WorksheetExists(.Cells(lFileToOpen, 8).Value) Then
.Cells(lFileToOpen, 12).Value = "Sheet does not exist in target workbook!"
Else
UserForm_GetFiles.Label_Now.Caption = "modify active worksheet"
UserForm_GetFiles.Repaint
Sheets(.Cells(lFileToOpen, 8).Value).Activate
'**************** HIER DEIN CODE *****************
'#### Ab hier sollte der Inhalt der göffneten Date übernommen werden und im Sheet _
Tabelle geschrieben werden.
'#### Anrede ist in Zelle H7 Name und Vorname in Zelle H8 Adresse in H9 PLZ und Ort _
in H10
Dim strInhalt
iErrNum = 3
With ActiveSheet.Shapes("Textfeld 2")
strInhalt = Split(.OLEFormat.Object.Text, Chr(10))
End With
Range("H7").Resize(UBound(strInhalt) + 1, 1) = Application.Transpose(strInhalt)
Range("H10") = LTrim(Right(Range("H9"), Len(Range("H9")) - InStrRev(Range("H9"), " _
")))
Range("H9") = RTrim(Application.Substitute(Range("H9"), Range("H10"), ""))
ActiveSheet.Shapes("Textfeld 2").Select
ActiveSheet.Shapes("Textfeld 2").Delete
'**************** HIER DEIN CODE *****************
'Adressdaten in Zieltabelle übertragen
lZeileZiel = lZeileZiel + 1
wksZiel.Cells(lZeileZiel, 1) = Range("H7")
wksZiel.Cells(lZeileZiel, 2) = Range("H8")
wksZiel.Cells(lZeileZiel, 3) = Range("H9")
wksZiel.Cells(lZeileZiel, 4) = Range("H10")
End If
UserForm_GetFiles.Label_Now.Caption = "close file"
UserForm_GetFiles.Repaint
wkbNew.Save
closeAndSkip:
wkbNew.Close False
skipThis:
Next lFileToOpen
.Activate
GetMoreSpeed (False)
End With
GoTo heaven
hell:
If iErrNum = 1 Then
Sheet1.Cells(lFileToOpen, 12).Value = "worksheet name is invalid! Avoid these characters in _
sheet-names : / \ ? * [ ] and dont leave it blank"
Application.DisplayAlerts = False
ActiveSheet.Delete
Application.DisplayAlerts = True
GoTo skipThis
End If
If iErrNum = 2 Then
Sheet1.Cells(lFileToOpen, 12).Value = "worksheet path is invalid! Please double check path / _
folder."
iErrNum = 0
GoTo skipThis
End If
If iErrNum = 3 Then
Sheet1.Cells(lFileToOpen, 12).Value = "No TEXTFELD2 in this sheet!"
iErrNum = 0
GoTo closeAndSkip
End If
MsgBox ("QUIT with error, please contact www.herber.de !")
heaven:
End Sub