Makro zum Datenaktualisieren

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub Konsolidieren() Dim wbQuelle As Workbook, wbZiel As Workbook Dim wksZiel As Worksheet Set wbZiel = ActiveWorkbook Call BlattInhaltKopieren(strQuelle:="C:\Test\Datei11.xls", varSheet:=1, _ wksZiel:=wbZiel.Worksheets("Tabelle_1")) Call BlattInhaltKopieren(strQuelle:="C:\Test\Datei22.xls", varSheet:=1, _ wksZiel:=wbZiel.Worksheets("Tabelle_2")) 'usw. End Sub Sub BlattInhaltKopieren(strQuelle As String, varSheet, wksZiel As Worksheet) wksZiel.UsedRange.Clear Dim wbQuelle As Workbook, wksQuelle As Worksheet Set wbQuelle = Workbooks.Open(Filename:=strQuelle, ReadOnly:=True) Set wksQuelle = wbQuelle.Worksheets(varSheet) Sub BlattInhaltKopieren(strQuelle As String, varSheet, wksZiel As Worksheet) wksZiel.UsedRange.Clear Dim wbQuelle As Workbook, wksQuelle As Worksheet Set wbQuelle = Workbooks.Open(Filename:=strQuelle, ReadOnly:=True) Set wksQuelle = wbQuelle.Worksheets(varSheet) With wksQuelle .Range("A1:G1").EntireColumn.Copy Destination:=wksZiel.Cells(1, 1) End With Application.CutCopyMode = False wbQuelle.Close savechanges:=False End Sub Application.CutCopyMode = False wbQuelle.Close savechanges:=False End Sub

Sub Daten_Aktualisieren() Dim wbQuelle As Workbook, wbZiel As Workbook Dim wksZiel As Worksheet Set wbZiel = ActiveWorkbook Call BlattInhaltKopieren(strQuelle:="\\Fileserver\fe1-allg\Controlling\Controlling SMD-Linien\ _ Controlling SMD Linie 1.xls", varSheet:="Controlling SMD Linie 1", _ wksZiel:=wbZiel.Worksheets("Controlling SMD Linie 1")) Call BlattInhaltKopieren(strQuelle:="\\Fileserver\fe1-allg\Controlling\Controlling SMD-Linien\ _ Controlling SMD Linie 2.xls", varSheet:="Controlling SMD Linie 2", _ wksZiel:=wbZiel.Worksheets("Controlling SMD Linie 2")) Call BlattInhaltKopieren(strQuelle:="\\Fileserver\fe1-allg\Controlling\Controlling SMD-Linien\ _ Controlling SMD Linie 3.xls", varSheet:="Controlling SMD Linie 3", _ wksZiel:=wbZiel.Worksheets("Controlling SMD Linie 3")) Call BlattInhaltKopieren(strQuelle:="\\Fileserver\fe1-allg\Controlling\Controlling SMD-Linien\ _ Controlling SMD Linie 4.xls", varSheet:="Controlling SMD Linie 4", _ wksZiel:=wbZiel.Worksheets("Controlling SMD Linie 4")) Call BlattInhaltKopieren(strQuelle:="\\Fileserver\fe1-allg\Controlling\Controlling SMD-Linien\ _ Controlling SMD Linie 5.xls", varSheet:="Controlling SMD Linie 5", _ wksZiel:=wbZiel.Worksheets("Controlling SMD Linie 5")) Call BlattInhaltKopieren(strQuelle:="\\Fileserver\fe1-allg\Controlling\Controlling SMD-Linien\ _ Controlling SMD Linie 6.xls", varSheet:="Controlling SMD Linie 6", _ wksZiel:=wbZiel.Worksheets("Controlling SMD Linie 6")) End Sub

Sub BlattInhaltKopieren(strQuelle As String, varSheet, wksZiel As Worksheet) wksZiel.Range("A1:N1").Clear ' hab den Bereich definiert Dim wbQuelle As Workbook, wksQuelle As Worksheet Set wbQuelle = Workbooks.Open(Filename:=strQuelle, ReadOnly:=True) * Set wksQuelle = wbQuelle.Worksheets(varSheet) With wksQuelle .Range("A1:N1").EntireColumn.Copy Destination:=wksZiel.Cells(1, 1) End With Application.CutCopyMode = False wbQuelle.Close savechanges:=False End Sub

Hallo baumpaul,
hier die Prozeduren etwas modifiziert/vereinfacht und ergänzt um eine Fehlerprüfung. Da die Dateien und Blätetr fortlaufende Zählnummern haben, kann man den Aufruf der Sub-Routine in eine For-Next-Schleife packen.
Ich hab es mit Dateien auf lokalem Laufwerk getestet, sollte aber auch mit Netztlaufwerk gehen.
Gruß
Franz


Sub Daten_Aktualisieren()
Dim wbZiel As Workbook, intI As Integer
Dim strPfad$, strDatei$, strBlattQ, strBlattZ$
On Error GoTo Fehler
Application.ScreenUpdating = False
Set wbZiel = ActiveWorkbook
strPfad = "\\Fileserver\fe1-allg\Controlling\Controlling SMD-Linien"
'  strPfad = "C:\Lokale daten\Test\Auftraege"
For intI = 1 To 6
strDatei = "Controlling SMD Linie " & intI & ".xls"
strBlattQ = "Controlling SMD Linie " & intI
strBlattZ = strBlattQ
Call BlattInhaltKopieren(strVerzeichnis:=strPfad, strQuelle:=strDatei, _
varSheet:=strBlattQ, wksZiel:=wbZiel.Worksheets(strBlattZ))
Next
Fehler:
With Err
If .Number  0 Then
MsgBox "Fehler-Nr. " & Err.Number & vbLf & .Description
End If
End With
Application.ScreenUpdating = True
End Sub
Sub BlattInhaltKopieren(strVerzeichnis$, strQuelle$, varSheet, wksZiel As Worksheet)
Dim wbQuelle As Workbook, wksQuelle As Worksheet, bolOpen As Boolean
Dim intFehler As Integer
'Alles(Inhalte + Formate + Kommentare + Gliederung) in Spalten A bis N löschen
On Error GoTo Fehler
intFehler = 1
With wksZiel.Range("A1:N1")
.EntireColumn.Clear
End With
'Prüfen ob Quelle schon geöffnet
intFehler = 0
If fncDateiOpen(strQuelle) = True Then
Set wbQuelle = Workbooks(strQuelle)
bolOpen = True
Else
intFehler = 2
Set wbQuelle = Workbooks.Open(Filename:=strVerzeichnis & "\" & strQuelle, ReadOnly:=True)
bolOpen = False
End If
'Quelltabelle setzen
intFehler = 3
Set wksQuelle = wbQuelle.Worksheets(varSheet)
intFehler = 4
With wksQuelle
.Range("A1:N1").EntireColumn.Copy Destination:=wksZiel.Cells(1, 1)
End With
intFehler = 0
Application.CutCopyMode = False
If bolOpen = False Then
wbQuelle.Close savechanges:=False
End If
Fehler:
With Err
If .Number  0 Then
Select Case intFehler
Case 1
MsgBox "Fehler-Nr. " & Err.Number & vbLf & .Description & vbLf & vbLf _
& "Problem beim Löschen in Zieltabelle """ & wksZiel.Name & """"
Case 2
MsgBox "Fehler-Nr. " & Err.Number & vbLf & .Description & vbLf & vbLf _
& "Problem beim Öffnen von Datei """ & strQuelle & """"
Case 3
MsgBox "Fehler-Nr. " & Err.Number & vbLf & .Description & vbLf & vbLf _
& "Problem beim Setzen der Quelltabeel  """ & strQuelle & """"
Case 4
MsgBox "Fehler-Nr. " & Err.Number & vbLf & .Description & vbLf & vbLf _
& "Problem beim Kopieren der Daten aus Quelle nach Ziel  """ & strQuelle & """"
Case Else
MsgBox "Fehler-Nr. " & Err.Number & vbLf & .Description & vbLf & vbLf _
& "Bitte korrekte Schreibweise von Blatt und Dateinamen prüfen!"
End Select
Application.ScreenUpdating = True
End If
End With
End Sub
Function fncDateiOpen(strDateiname As String) As Boolean
Dim wb As Workbook
'Prüft, ob Arbeitsmapee schon geöffnet
For Each wb In Application.Workbooks
If LCase(wb.Name) = LCase(strDateiname) Then
fncDateiOpen = True
Exit Function
End If
Next
End Function

Beliebteste Forumthreads (12 Monate)

4
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

214 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Makro zum Datenaktualisieren

4 Beiträge zum Forumthread Beiträge zu diesem Forumthread

214 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

4
Beiträge zum Forumthread

Beiträge zu diesem Forumthread