Microsoft Excel

Herbers Excel/VBA-Archiv

Informationen und Beispiele zum Thema InputBox
BildScreenshot zu InputBox InputBox-Seite mit Beispielarbeitsmappe aufrufen
Informationen und Beispiele zum Thema MsgBox
BildScreenshot zu MsgBox MsgBox-Seite mit Beispielarbeitsmappe aufrufen

@ FP: Datenkonsolidierungsmakro

Betrifft: @ FP: Datenkonsolidierungsmakro
von: Ramses
Geschrieben am: 17.04.2003 - 14:42:55

Hallo FP,

ich weiss nicht ob du deinen ersten Thread noch weiter verfolgst, deshalb hier nochmal:

Das Makro frägt den Pfad\bzw. das Verzeichnis ab in dem die Dateien liegen. Bitte den Pfad Exact angeben in dieser Form "C:\Verzeichnis".
Das Makro prüft und öffnet deine 500 Dateien und transferiert die Daten in die aktuelle Arbeitsmappe in eine Tabelle mit dem Namen "Datenkonsolidierung".
In der Statusbar wird die aktuell bearbeitete Tabelle angezeigt.


Deine Daten liegen in dieser Form vor:

Tabelle1
 BCDEF
9512   
963    
974    
9856   
997    
100891011 
10112131415 
1021617181920
1032122232425
1042627282930
1053132333435
10636373839 
10740414243 
10844454647 
10948495051 
11052535455 
11156575859 
11260616263 
11364656667 
11468697071 
11572737475 
Excel Tabellen einfach im Web darstellen   Excel Jeanie HTML  2.0    Download  


Kopiere das Makro in eine die Arbeitsmappe wo du die Konsolidierung durchführen willst:


Option Explicit

Sub Consolidation_of_external_Files()
Dim i As Long, n As Integer, m As Integer, TotFiles As Long
Dim Cr As Long, Cc As Integer, Qe As Integer, myError As Integer
Dim gefFile As String, dname As String, Dateiform As String
Dim Suchpfad As String, suchbegriff As String
Dim dataWks As String, startWks As String, aktWkb As String
Dim oldStatus As Variant
'Variablen füllen
'Zeilen Start der Datenerfassung in der Konsolidierungstabelle
Cr = 2
Cc = 1
'Namen der Tabelle definieren
dataWks = "Konsolidierungsdaten"
startWks = ActiveSheet.Name
aktWkb = ActiveWorkbook.Name
'Datentyp definieren
Dateiform = "*.xls"
'existierende Konsolidierungstabelle suchen
For i = 1 To Worksheets.Count
    If Worksheets(i).Name = dataWks Then
        Qe = MsgBox("Die Konsolidierungstabelle existiert schon!" & Chr$(13) & "Soll sie gelöscht werden?", vbCritical + vbDefaultButton2 + vbYesNo, "Datenkonflikt")
        If Qe = vbNo Then
            MsgBox ("Das Makro kann nicht ausgeführt werden wegen entstehenden Datenkonflikten")
            Exit Sub
        End If
        Application.DisplayAlerts = False
        Worksheets(i).Delete
        Application.DisplayAlerts = True
        Exit For
    End If
Next i
Worksheets.Add
ActiveSheet.Name = dataWks
Worksheets(startWks).Select
On Error GoTo Errorhandler
myError = 1
'Pfad anfordern
Suchpfad = InputBox("Geben Sie den Ordner an, der durchsucht werden soll.", "Pfad definieren", Application.DefaultFilePath)
If Suchpfad = "" Then Exit Sub
ChDir Suchpfad
'Start der Datenverarbeitung
Application.ScreenUpdating = False
oldStatus = Application.StatusBar
'Pfad durchsuchen
With Application.FileSearch
    .LookIn = Suchpfad
    .SearchSubFolders = False
    .Filename = Dateiform
    myError = 2
    If .Execute() > 0 Then
        TotFiles = .FoundFiles.Count
        Application.StatusBar = "Total " & TotFiles & " gefunden"
        For i = 1 To (.FoundFiles.Count)
            gefFile = .FoundFiles(i)
            Application.StatusBar = "Mappe " & i & " von total " & TotFiles & " in Bearbeitung"
            Workbooks.Open Filename:=gefFile
            Range("B95").Copy Destination:=Workbooks(aktWkb).Worksheets(dataWks).Cells(i + 1, Cc)
            Cc = Cc + 1
            Range("C95").Copy Destination:=Workbooks(aktWkb).Worksheets(dataWks).Cells(i + 1, Cc)
            Cc = Cc + 1
            Range("B96").Copy Destination:=Workbooks(aktWkb).Worksheets(dataWks).Cells(i + 1, Cc)
            Cc = Cc + 1
            Range("B97").Copy Destination:=Workbooks(aktWkb).Worksheets(dataWks).Cells(i + 1, Cc)
            Cc = Cc + 1
            Range("b98").Copy Destination:=Workbooks(aktWkb).Worksheets(dataWks).Cells(i + 1, Cc)
            Cc = Cc + 1
            Range("C98").Copy Destination:=Workbooks(aktWkb).Worksheets(dataWks).Cells(i + 1, Cc)
            Cc = Cc + 1
            Range("B99").Copy Destination:=Workbooks(aktWkb).Worksheets(dataWks).Cells(i + 1, Cc)
            Cc = Cc + 1
            'Schleife für B100 - E 101
            For n = 100 To 101
                For m = 2 To 5
                    Cells(n, m).Copy Destination:=Workbooks(aktWkb).Worksheets(dataWks).Cells(i + 1, Cc)
                    Cc = Cc + 1
                Next m
            Next n
            'Schleife für B102 - F105
            For n = 102 To 105
                For m = 2 To 5
                    Cells(n, m).Copy Destination:=Workbooks(aktWkb).Worksheets(dataWks).Cells(i + 1, Cc)
                    Cc = Cc + 1
                Next m
            Next n
            'Schleife für B106 - E115
            For n = 102 To 115
                For m = 2 To 4
                    Cells(n, m).Copy Destination:=Workbooks(aktWkb).Worksheets(dataWks).Cells(i + 1, Cc)
                    Cc = Cc + 1
                Next m
            Next n
            ActiveWorkbook.Close savechanges:=False
            Cc = 1
        Next i
    End If
End With
MsgBox "Alle Dateien in " & Suchpfad & " bearbeitet"

OK_Exit:
Application.StatusBar = oldStatus
Application.ScreenUpdating = True
Exit Sub

Errorhandler:
Select Case myError
    Case 1
        MsgBox "Der Pfad existiert nicht" & Chr$(13) & "Das Makro wird beendet"
    Case 2
        MsgBox "Undefinierter Datenfehler: Das Makro wird abgebrochen"
End Select
Resume OK_Exit
End Sub 

     Code eingefügt mit Syntaxhighlighter 1.16


Das Ergebnis sieht dann so aus:


Konsolidierungsdaten
 ABCDEFGHI
1         
21234567910
31234567910
41234567910
Excel Tabellen einfach im Web darstellen   Excel Jeanie HTML  2.0    Download  

Die restlichen 61 Spalten habe ich jetzt hier nicht dargestellt.
Die Überschriften musst du noch selbst definieren.

Gruss und viel Spass

Rainer

  

Re: @ FP: Datenkonsolidierungsmakro
von: FP
Geschrieben am: 17.04.2003 - 15:23:41

Hallo Rainer

Ich verfolge den Thread und versuche verzweifelt das umzusetzen.

Leider funktioniert es aber nicht. Mit Makros habe ich bis anhin nur sehr wenig gearbeitet. Nur Makros mit der Funktion Aufzeichnen.

Wie ich bis anhin vorgegangen bin:
Extras/Makros - Makros... --> Name eingeben und Erstellen.
Danach deinen Makro reinkopieren und los (sollte es gehen.) oder?

Auf jeden Fall bringt er die Fehlermeldung: "Fehler beim Kompilieren" Erwartet:=

Grüsse


  

Re: @ FP: Datenkonsolidierungsmakro
von: Ramses
Geschrieben am: 17.04.2003 - 15:34:44

Hallo,

Das geht auf folgende Weise:

Extras - Makros - VB-Editor starten
Im linken Fenster hast du nun die Projektübersicht
Klick auf die Arbeitsmappe wohin das Makro kommen soll
Rechte Maustaste - Einfügen - Modul
Kopiere den ganzen Code wie oben gezeigt dort hinein

ACHTUNG:
Qe = MsgBox("Die Konsolidierungstabelle existiert schon!" & Chr$(13) & "Soll sie gelöscht werden?", vbCritical + vbDefaultButton2 + vbYesNo, "Datenkonflikt")

Diese Zeile MUSS in EINER Zeile stehen

Jetzt kannst du über Extras - Makro - Makro ausführen das Makro auswählen und starten.

Gruss Rainer

  

Re: @ FP: Datenkonsolidierungsmakro
von: FP
Geschrieben am: 17.04.2003 - 15:55:27


Also........

"Das geht auf folgende Weise:

Extras - Makros - VB-Editor starten
Im linken Fenster hast du nun die Projektübersicht
Klick auf die Arbeitsmappe wohin das Makro kommen soll
Rechte Maustaste - Einfügen - Modul
Kopiere den ganzen Code wie oben gezeigt dort hinein

ACHTUNG:
Qe = MsgBox("Die Konsolidierungstabelle existiert schon!" & Chr$(13) & "Soll sie gelöscht werden?", vbCritical + vbDefaultButton2 + vbYesNo, "Datenkonflikt")

Diese Zeile MUSS in EINER Zeile stehen"

......bis hierher alles klar. Die o.g. Zeile steht auch in einer Zeile. Aber, danach geht nichts.
Ueber Extras - Makro - Makros erscheint nichts, und wenn ich es speichere bringt er die Fehlermeldung:
"Fehler beim Kompilieren. Ausserhalb der Prozedur ungültig"

Grüsse


  

Ich schick dir die Tabelle zu o.T.
von: Ramses
Geschrieben am: 17.04.2003 - 15:57:53

...

  

Re: Ich schick dir die Tabelle zu o.T.
von: FP
Geschrieben am: 17.04.2003 - 16:53:45

Hallo Rainer

Herzlichen Dank!

Funktioniert (fast) perfekt.

Denn leider: a) Die Daten sind auf der 2 Tabelle in der Datei und b) die Zahlen und Buchstaben sind ein Ergebnis aus dem 1 Blatt in der Datei. (Ergebnis aus anklicken oder nicht eines Steuerlementes) Wenn er nun diese kopiert erscheint im jeweiligen Feld BEZUG.

Ich habe es jetzt folgendermassen versucht, das Blatt 2 angeklickt. (erscheint nun beim öffnen) und die Felder kopiert / Inhalte einfügen - Werte.

Nun funktioniert es, aber ich müsste diese Aenderungen auf allen 500 Dateien machen.

Kann man das auch lösen?

Uebrigens, du auch aus oder in der Schweiz?

Grüsse

  

Funktioniert fast.....
von: FP
Geschrieben am: 17.04.2003 - 17:27:52

Hallo Rainer

Herzlichen Dank!

Funktioniert (fast) perfekt.

Denn leider: a) Die Daten sind auf der 2 Tabelle in der Datei und b) die Zahlen und Buchstaben sind ein Ergebnis aus dem 1 Blatt in der Datei. (Ergebnis aus anklicken oder nicht eines Steuerlementes) Wenn er nun diese kopiert erscheint im jeweiligen Feld BEZUG.

Ich habe es jetzt folgendermassen versucht, das Blatt 2 angeklickt. (erscheint nun beim öffnen) und die Felder kopiert / Inhalte einfügen - Werte.

Nun funktioniert es, aber ich müsste diese Aenderungen auf allen 500 Dateien machen.

Kann man das auch lösen?

Uebrigens, du auch aus oder in der Schweiz?

Grüsse

  

Re: Funktioniert fast.....
von: Ramses
Geschrieben am: 17.04.2003 - 18:39:43

Hallo

Ja, auch aus der Schweiz :-)
Heissen die 2. Tabellen immer gleich ?
Der Rest ist kein Problem.

Gruss Rainer

  

Re: Funktioniert fast.....
von: Tabellen-Name
Geschrieben am: 17.04.2003 - 19:10:39

Hallo

Ja, die Tabellenblätter heissen immer gleich.

Gruss

  

Tabellen-Name
von: FP
Geschrieben am: 17.04.2003 - 19:12:24

Hallo

Ja, die Tabellenblätter heissen immer gleich.

Gruss

  

Du hast Post :-) o.T.
von: Ramses
Geschrieben am: 17.04.2003 - 19:32:44

...

  

Re: Du hast Post :-) o.T.
von: Ramses
Geschrieben am: 17.04.2003 - 19:33:04

...