Live-Forum - Die aktuellen Beiträge
Anzeige
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Makro zum Datenaktualisieren

Makro zum Datenaktualisieren
18.02.2009 13:18:00
Baumpaul1
Hallo liebe Excelfreunde,
ich habe folgendes Problem: Ich habe 6 verschiedene Dateien die laufend mit Daten befüllt werden und ich muss von den Daten Auswertungen erstellen, die ich nur in einer anderen Datei machen kann. Mit der Datenaktualisierung von Excel werden die Daten ohne Formatierung in die 2. Datei geschrieben= ganz schlecht.
ich bräuchte ein Makro, dass die Spalten von Z.B. A-G von Datei 1 Tabelle 1 in die 2. Datei mit Formatierung und Kommentaren kopiert. Die Dateien befinden sich im Netzwerk und die 1.Datei ist Schreibgeschützt. Die Originaltabellen aus den 6 verschiedenen Dateien will ich in einer Datei mit 6 Tabellen weiterbearbeiten.
Bitte um Hilfe!
Gruss
Baumpaul1

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

Betreff
Datum
Anwender
Anzeige
AW: Makro zum Datenaktualisieren
18.02.2009 19:25:00
fcs
Hallo Baumpaul,
im Archiv sollte dazu doch sicher was zu finden sein.
Im Grundasatz sollte das folgende funktionieren - hab ich aber nicht getestet.
Gruß
Franz

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


Anzeige
AW: Makro zum Datenaktualisieren
19.02.2009 10:36:00
Baumpaul1
Hallo Franz,
vielen Dank für deine Antwort! Ich hab die Variante mit Spaltenauswahl bei mir eingefügt, sieht bei mir vie folgt aus:

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


2 Probleme hab ich noch, es wird nur die 1. Datenabfrage gemacht, danach kommt eine Fehlermeldung (eine vereinzelte Abfrage funktioniert) und wenn die Quelldatei schon geöffnet ist, dann hab ich eine Fehlermeldung und es wird abgebrochen.
hast Du vielleicht für diese Probleme eine Lösung?
Vielen Dank für deine Hilfe!
Gruss
Baumpaul1

Anzeige
AW: Makro zum Datenaktualisieren
20.02.2009 10:23:00
fcs
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


Anzeige
AW: Makro zum Datenaktualisieren
20.02.2009 12:44:00
Baumpaul1
Hallo Franz,
Echt der Hammer von Dir! Danke vielmals!!
Klappt super!!
vielen Dank nochmals, dass du dich meinem Problem angenommen hast!
Gruss
Baumpaul1

166 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige