Microsoft Excel

Herbers Excel/VBA-Archiv

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

Makro um Blätter von versch. Dateien einzubinden

Betrifft: Makro um Blätter von versch. Dateien einzubinden von: Andi
Geschrieben am: 28.08.2014 12:52:02

Hey,

ich bräuchte ein Makro, was folgendes kann (Habe da leider nicht mal einen Ansatz für...):

Ich habe sehr viele (ca. 80) gleich aufgebaute Excel-Dateien. Das Makro soll mir jetzt von diesen ganzen Dateien, die Daten im Tabellenblatt "Übersicht" ab einer entsprechenden Zeile (die ist immer gleich) bis zur letzten beschriebenen Zeile untereinander kopieren (nur Werte!).

Ist das überhaupt möglich? Oder muss ich mir etwas anderes einfallen lassen?

  

Betrifft: AW: Makro um Blätter von versch. Dateien einzubinden von: yummi
Geschrieben am: 28.08.2014 13:01:00

Hallo Andi,

mal ein Ansatz wie Du Daten ohne öffnen der Datei lesen kannst.

For intRow = 1 To 4
Cells(intRow, 5) = ExecuteExcel4Macro("'E:\Test\[test1.xls]Tabelle2'!" & _
Cells(intRow, 2).Address(ReferenceStyle:=xlR1C1))
Next intRow

Schreibt die Einträge aus B1:B4 der angegebenen Datei in E1:E4.

Wenn Du darum noch eine Schleife baust, die dir alle Dateien findet und diese dann als Variable an ExecuteExcel4Macro übergibst, sollte es alles liefern. Beachte aber die eckigen Klammern!!!

Gruß
yummi


  

Betrifft: AW: Makro um Blätter von versch. Dateien einzub. von: Andi
Geschrieben am: 28.08.2014 13:12:57

Könnte ich die Dateien auch über die get.open.filename Funktion auswählen (Mehrfachauswahl)? Der Name der Dateien ist nämlich unterschiedlich.

Oder kann ich das Makro die Aktion für alle im gleichen Ordner befindlichen Dateien ausführen lassen?


  

Betrifft: AW: Makro um Blätter von versch. Dateien einzub. von: Andi
Geschrieben am: 28.08.2014 13:13:03

Könnte ich die Dateien auch über die get.open.filename Funktion auswählen (Mehrfachauswahl)? Der Name der Dateien ist nämlich unterschiedlich.

Oder kann ich das Makro die Aktion für alle im gleichen Ordner befindlichen Dateien ausführen lassen?


  

Betrifft: AW: Makro um Blätter von versch. Dateien einzub. von: Andi
Geschrieben am: 28.08.2014 13:13:09

Könnte ich die Dateien auch über die get.open.filename Funktion auswählen (Mehrfachauswahl)? Der Name der Dateien ist nämlich unterschiedlich.

Oder kann ich das Makro die Aktion für alle im gleichen Ordner befindlichen Dateien ausführen lassen?


  

Betrifft: Makro um Blätter von versch. Dateien einzubinden von: Andi
Geschrieben am: 28.08.2014 13:13:36

Könnte ich die Dateien auch über die get.open.filename Funktion auswählen (Mehrfachauswahl)? Der Name der Dateien ist nämlich unterschiedlich.

Oder kann ich das Makro die Aktion für alle im gleichen Ordner befindlichen Dateien ausführen lassen?


  

Betrifft: Ansatz von: Andi
Geschrieben am: 28.08.2014 13:14:16

Könnte ich die Dateien auch über die get.open.filename Funktion auswählen (Mehrfachauswahl)? Der Name der Dateien ist nämlich unterschiedlich.

Oder kann ich das Makro die Aktion für alle im gleichen Ordner befindlichen Dateien ausführen lassen?


  

Betrifft: Ansatz von: Andi
Geschrieben am: 28.08.2014 13:14:17

Könnte ich die Dateien auch über die get.open.filename Funktion auswählen (Mehrfachauswahl)? Der Name der Dateien ist nämlich unterschiedlich.

Oder kann ich das Makro die Aktion für alle im gleichen Ordner befindlichen Dateien ausführen lassen?


  

Betrifft: AW: Ansatz von: fcs
Geschrieben am: 28.08.2014 14:36:25

Hallo Andi,

hier das Gerüst für ein entsprechendes Makro.

Gruß
Franz

Sub DatenZusammensuchen()
  Dim wkbQuelle As Workbook, wksQuelle As Worksheet, varQuelle As Variant
  Dim wkbZiel As Workbook, wksZiel As Worksheet
  Dim Zeile_Z As Long, Zeile_Q As Long, Zeile_Q1 As Long
  Dim Zelle As Range, rngCopy As Range
  
  On Error GoTo Fehler
  
  Set wkbZiel = ActiveWorkbook
  Set wksZiel = wkbZiel.Worksheets("Tabelle1")
  
  With wksZiel
    '1. Einfügezeile in Ziel-abelle ermitteln
    Set Zelle = .Cells.Find(What:="*", After:=.Cells(1, 1), LookIn:=xlValues, _
        lookat:=xlWhole, searchorder:=xlByRows, searchdirection:=xlPrevious)
    If Zelle Is Nothing Then
        Zeile_Z = 1
    Else
        Zeile_Z = Zelle.Row + 1
    End If
  End With
  
  With Application.FileDialog(msoFileDialogOpen)
    .Title = "Bitte die Datei mit den Quelldaten auswählen (Mehrfach-Auswahl ist möglich)"
    .AllowMultiSelect = True
    Application.ScreenUpdating = False
    If .Show = -1 Then
      For Each varQuelle In .SelectedItems
        
        Set wkbQuelle = Application.Workbooks.Open(varQuelle, ReadOnly:=True)
        Set wksQuelle = wkbQuelle.Worksheets("Übersicht")       ' - ggf. anpassen
        Zeile_Q1 = 3 '1. zu kopierende Zeile in Quellblättern   - ggf. anpassen
        
        With wksQuelle
          Set Zelle = .Cells.Find(What:="*", After:=.Cells(1, 1), LookIn:=xlValues, _
              lookat:=xlWhole, searchorder:=xlByRows, searchdirection:=xlPrevious)
          If Zelle Is Nothing Then
              'keine Daten im Tabellenblatt - leeres Blatt
          ElseIf Zelle.Row < Zeile_Q1 Then
              'keine Daten zum Kopieren im Tabellenblatt
          Else
              Zeile_Q = Zelle.Row
              Set rngCopy = .Range(.Rows(Zeile_Q1), .Rows(Zeile_Q))
          End If
        End With
        
        With wksZiel
          rngCopy.Copy
          With .Cells(Zeile_Z, 1)
'            .PasteSpecial Paste:=xlPasteFormats
            .PasteSpecial Paste:=xlPasteValues
          End With
          Zeile_Z = Zeile_Z + rngCopy.Rows.Count
        End With
        
        Application.CutCopyMode = False
        wkbQuelle.Close savechanges:=False
ResumeNextDatei:
        Set wkbQuelle = Nothing
      Next varQuelle
    End If
  End With
  
Fehler:
  Application.ScreenUpdating = True
  With Err
    Select Case .Number
      Case 0 'alles OK
      Case 9
        MsgBox "Fehler-Nr.: " & .Number & vbLf & .Description & vbLf & vbLf _
          & "Tabelle ""Übersicht"" ist in Quelldatei """ & ActiveWorkbook.Name _
          & """ nicht nicht vorhanden", vbOKOnly, "Fehlerprüfung"
        If Not wkbQuelle Is Nothing Then wkbQuelle.Close savechanges:=False
        Resume ResumeNextDatei
      Case Else
        MsgBox "Fehler-Nr.: " & .Number & vbLf & .Description, _
          vbOKOnly, "Fehlerprüfung"
    End Select
  End With
  If Not wkbQuelle Is Nothing Then wkbQuelle.Close savechanges:=False

End Sub



  

Betrifft: AW: Ansatz von: Andi
Geschrieben am: 28.08.2014 15:11:21

Der Wahnsinn!!! Schon mal vielen herzlichen Dank.

Mir ist allerdings gerade aufgefallen, dass ich in der letzten Zeile der Quelldatei immer die Summe angebe. Wo im Code kann ich das verändern, dass er die letzte Zeile nicht mit kopiert?

PS: Ich weiß nicht genau wie man Beiträge löschen kann. Irgendwie habe ich den vorherigen Beitrag gefühlt 100 mal erstelle -.-


  

Betrifft: AW: Ansatz von: fcs
Geschrieben am: 28.08.2014 15:39:41

Hallo Andi,

ändere die Zeile

              Zeile_Q = Zelle.Row

in
              Zeile_Q = Zelle.Row -1
Beiträge kannst du nicht löschen.
Meines Wissens vermeidest du die Mehrfacheinträge wenn du nach dem Absenden der Frage/Antwort in dem Angezeigten Fenster "Speicherbestätihgung" rechts unten den Link "Zurück zur Forumsliste" anklickst.
Auf keinen Fall die Browserfunktion "Seite zurück" nutzen!

Gruß
Franz


  

Betrifft: AW: Ansatz von: Andi
Geschrieben am: 29.08.2014 09:42:35

Super, Danke! Funktioniert!

Ein Problem habe ich noch:

In den Tabellen, die kopiert werden sollen, ist unter der Summenzeile eine Formel, die den Wert "" ausgibt. Das Makro kopiert jetzt aber alle Zeilen, die diese Formel enthalten ebenfalls!

Könnte man einbauen, dass nur Zellen <>"" kopiert werden oder irgendwie so?


  

Betrifft: AW: Ansatz von: fcs
Geschrieben am: 29.08.2014 10:56:39

Hallo Andi,

das Makro sucht in der jetzigen Form schon nach der letzten Zelle/Zeile mit einem Wert <>"".

Unterhalb der Zeile mit der Summenformel müssen noch Zellen mit Werten (z.B. Leerzeichen) vorhanden sein.

Gruß
Franz


  

Betrifft: AW: Ansatz von: Andi
Geschrieben am: 29.08.2014 13:41:41

Hallo Franz,

ich habe es nochmal kontrolliert. Das ganze funktioniert nur, wenn ich die Formeln lösche! Wenn ich sie drin lasse (und sie geben definitiv alle "" aus) dann kopiert mir das Skript alle Zellen, die diese Formel enthalten.


  

Betrifft: AW: Ansatz von: fcs
Geschrieben am: 29.08.2014 14:51:14

Halo Andi,

ich hab es jetzt nochmals intensiv getestet und es funktioniert definitiv.
Meine Testformel für die Summenspalte F:

=WENN(A99="Summe";SUMME($F$3:F98);WENN(ANZAHL2(A99:E99)=0;"";SUMME(B99:E99)))

Die Formeln gehen bis Zeile 104, in Zelle A98 steht "Summe" und das Makro kopiert korrekt die Zeilen bis Zeile 97.

Aus meiner Sicht müssen da bei dir irgendwo unterhalb der Angezeigten Summenzeile mit Werte in anderen Zellen noch Werte stehen.

Gruß
Franz


  

Betrifft: AW: Ansatz von: Andi
Geschrieben am: 01.09.2014 08:29:52

Ich habe hier jetzt mal das Excelblatt hochgeladen. Wahrscheinlich ist es offensichtlich, aber ich finde den Fehler irgendwie nicht.

https://www.herber.de/bbs/user/92418.xlsm


  

Betrifft: AW: Ansatz von: yummi
Geschrieben am: 01.09.2014 09:54:07

Hallo Andi,

ohne eine Importdatei wird es schwierig nachzustellen ;-)

Gruß
yummi


  

Betrifft: AW: Ansatz von: Andi
Geschrieben am: 01.09.2014 10:55:20

Verstehe ich nicht so ganz. Es ist für mich lediglich relevant, ob die hochgeladenen Datei überall ="" ausgibt. Anscheinend nicht, sonst würde die Formel funktionieren... ich weiß allerdings nicht wo sie etwas anderes ausgibt!


  

Betrifft: AW: Ansatz von: yummi
Geschrieben am: 01.09.2014 11:18:10

Hallo Andi,

ich habe in F7 -H7 ein "-" stehen und in den rstlichen Feldern der zeile 7 #Bezug

Gruß
yummi


  

Betrifft: AW: Ansatz von: Andi
Geschrieben am: 01.09.2014 12:17:52

OK. Neuer Ansatz:

Wie muss ich denn den Code ändern, damit er nur in einer bestimmten Spalte die nächste leere Zelle sucht?


  

Betrifft: AW: Ansatz von: fcs
Geschrieben am: 01.09.2014 14:50:35

Hallo Andi,


es schein die Formatierung der Zellen zu sein, warum mein Makro in deiner Datei die Zellen mit Ergebnis "" als mit Daten gefüllt erkennt. Zetze ich das Zahlenformat auf Standerd, dann geht es.

Um jetzt mit dem vorhandenen Format die Letzte Zeile mit Ergebnis ungleich "" in einer Spalte zu ermittel kannst du die folgende Function benutzen.

Gruß
Franz

Sub bbTest()
  Dim Zeile_Q As Long, Zeile_Q1 As Long, rngCopy As Range
  Dim wkbQuelle As Workbook, wksQuelle As Worksheet
  Set wkbQuelle = ActiveWorkbook
  Set wksQuelle = wkbQuelle.Worksheets("Übersicht")
  With wksQuelle
    Zeile_Q1 = 3
    'Letzte Zeile verschieden von "" in Spalte F
    Zeile_Q = fncLetzteVerschieden_von_Leer(wks:=wksQuelle, Spalte:=6)
    If Zeile_Q = 0 Then
        MsgBox "'keine Daten im Tabellenblatt - leeres Blatt"
    ElseIf Zeile_Q < Zeile_Q1 Then
        MsgBox "keine Daten zum Kopieren im Tabellenblatt"
    Else
        Set rngCopy = .Range(.Rows(Zeile_Q1), .Rows(Zeile_Q))
        MsgBox "letzte Zeile mit Daten: " & Zeile_Q 'Testzeile
    End If
  End With
End Sub

Function fncLetzteVerschieden_von_Leer(wks As Worksheet, Optional Spalte As Long = 1) As Long
    'Funktion ermittelt in Spalte die letzte Zelle verschieden von ""
    Dim Zelle As Range
    Dim lngZeile As Long
    With wks
      Set Zelle = .Columns(Spalte).Find(What:="*", After:=.Cells(1, Spalte), LookIn:=xlValues,  _
_
          lookat:=xlWhole, searchorder:=xlByRows, searchdirection:=xlPrevious)
      If Zelle Is Nothing Then Exit Function
      For lngZeile = Zelle.Row To 1 Step -1
        If .Cells(lngZeile, Spalte) <> "" Then
          fncLetzteVerschieden_von_Leer = lngZeile
          Exit For
        End If
      Next
    End With
End Function



  

Betrifft: AW: Ansatz von: Andi
Geschrieben am: 01.09.2014 15:33:38

Danke, ich war schon am verzweifeln.
Jetzt noch eine Frage:

Wie binde ich deinen Code nun in den vorhandenen (das Gerüst welches du gepostet hast) ein. Bei meinem Versuch kommt: "Fehler-Nr.:13, Typen unverträglich".


  

Betrifft: AW: Ansatz von: Andi
Geschrieben am: 02.09.2014 07:29:18

Sub Betriebsbögen_importieren()
   Dim wkbQuelle As Workbook, wksQuelle As Worksheet, varQuelle As Variant
   Dim wkbZiel As Workbook, wksZiel As Worksheet
   Dim Zeile_Z As Long, Zeile_Q As Long, Zeile_Q1 As Long
   Dim Zelle As Range, rngCopy As Range
   
   On Error GoTo Fehler
   
   Set wkbZiel = ActiveWorkbook
   Set wksZiel = wkbZiel.Worksheets("Gesamtübersicht")
   
   With wksZiel
     '1. Einfügezeile in Ziel-abelle ermitteln
     Set Zelle = .Cells.Find(What:="*", After:=.Cells(1, 1), LookIn:=xlValues, _
         lookat:=xlWhole, searchorder:=xlByRows, searchdirection:=xlPrevious)
     If Zelle Is Nothing Then
         Zeile_Z = 1
     Else
         Zeile_Z = Zelle.Row + 1
     End If
   End With
   
   With Application.FileDialog(msoFileDialogOpen)
     .Title = "Bitte die Datei mit den Quelldaten auswählen (Mehrfach-Auswahl ist möglich)"
     .AllowMultiSelect = True
     Application.ScreenUpdating = False
     If .Show = -1 Then
       For Each varQuelle In .SelectedItems
         
         Set wkbQuelle = Application.Workbooks.Open(varQuelle, ReadOnly:=True)
         Set wksQuelle = wkbQuelle.Worksheets("Übersicht")
           With wksQuelle
    Zeile_Q1 = 7
    'Letzte Zeile verschieden von "" in Spalte F
    Zeile_Q = fncLetzteVerschieden_von_Leer(wks:=wksQuelle, Spalte:=6)
    If Zeile_Q = 0 Then
        MsgBox "'keine Daten im Tabellenblatt - leeres Blatt"
    ElseIf Zeile_Q < Zeile_Q1 Then
        MsgBox "keine Daten zum Kopieren im Tabellenblatt"
    Else
        Set rngCopy = .Range(.Rows(Zeile_Q1), .Rows(Zeile_Q))
        MsgBox "letzte Zeile mit Daten: " & Zeile_Q 'Testzeile
    End If
  End With

         
         With wksZiel
           rngCopy.Copy
           With .Cells(Zeile_Z, 1)
 '            .PasteSpecial Paste:=xlPasteFormats
             .PasteSpecial Paste:=xlPasteValues
           End With
           Zeile_Z = Zeile_Z + rngCopy.Rows.Count
         End With
         
         Application.CutCopyMode = False
         wkbQuelle.Close savechanges:=False
ResumeNextDatei:
         Set wkbQuelle = Nothing
       Next varQuelle
     End If
   End With
   
Fehler:
   Application.ScreenUpdating = True
   With Err
     Select Case .Number
       Case 0 'alles OK
       Case 9
         MsgBox "Fehler-Nr.: " & .Number & vbLf & .Description & vbLf & vbLf _
           & "Tabelle ""Übersicht"" ist in Quelldatei """ & ActiveWorkbook.Name _
           & """ nicht nicht vorhanden", vbOKOnly, "Fehlerprüfung"
         If Not wkbQuelle Is Nothing Then wkbQuelle.Close savechanges:=False
         Resume ResumeNextDatei
       Case Else
         MsgBox "Fehler-Nr.: " & .Number & vbLf & .Description, _
           vbOKOnly, "Fehlerprüfung"
     End Select
   End With
   If Not wkbQuelle Is Nothing Then wkbQuelle.Close savechanges:=False
 
 End Sub


Function fncLetzteVerschieden_von_Leer(wks As Worksheet, Optional Spalte As Long = 1) As Long
    'Funktion ermittelt in Spalte die letzte Zelle verschieden von ""
    Dim Zelle As Range
    Dim lngZeile As Long
    With wks
      Set Zelle = .Columns(Spalte).Find(What:="*", After:=.Cells(1, Spalte), LookIn:=xlValues,  _
_
          lookat:=xlWhole, searchorder:=xlByRows, searchdirection:=xlPrevious)
      If Zelle Is Nothing Then Exit Function
      For lngZeile = Zelle.Row To 1 Step -1
        If .Cells(lngZeile, Spalte) <> "" Then
          fncLetzteVerschieden_von_Leer = lngZeile
          Exit For
        End If
      Next
    End With
End Function
So funktioniert es irgendwie nicht...


  

Betrifft: AW: Ansatz von: fcs
Geschrieben am: 02.09.2014 11:36:58

Hallo Andi,

was funktioniert denn "irgendwie" nicht?

Ich hab deine Variante jetzt mal mit deiner Beispiel-Übersichtsdatei getestet und da werden die Zeilen scheinbar korrekt importiert.

Gruß
Franz


 

Beiträge aus den Excel-Beispielen zum Thema "Makro um Blätter von versch. Dateien einzubinden"