none
EXCELL VBA CODE HILFEEEEE RRS feed

  • Frage

  • Hallo ich brauche dringend Hilfe.

    Ich habe einen Ordner der sich Umweltprogramme nennt. In diesem sind mehrere Excelldateien mit  dem Namen Bereichsumweltprogramm dem selben Aufbau enthalten. Diese werden aus allen Bereichen ausgefüllt.

    Mein Ziel ist es jetzt, dass alle Dateien in einer Excelldatei die sich Werksumweltziele nennt importiert werden. ALLES AUF EINEM Tabellenblatt.

    Also alles was in den Bereichsumweltprogrammen steht in eine Excelltabelle kopiert werden. Alle Tabelllen sind gleich aufgebaut die Inhalte sollen also untereinander in einer Tabelle erscheinen. Anschließend soll diese Excelldatei Filtern und nur noch die Zeilen stehenlassen die ausgewählt wurden. (In der Excell ist eine Spalte für die Auswahl diese Spalte soll gefiltert werden alles andere soll gelöscht werden)

    Bisher habe ich diesen Code. Der funktioniert auch bis auf das er nur auf eine Datei zugreift anstatt wie auf den kompletten Ordner.

    Kann mir bitte dringend einer helfen.!?!?

    Freitag, 5. Januar 2018 12:40

Antworten

  • Als nächstes brauchst du eine ähnliche Funktion, welche den Bereich in deinem Quell-Tabellenblatt sucht, den du kopieren möchtest.

    Warum so kompliziert?

    Die Aufgabe ist doch klar gegeben:
    soll mein Code auf 12 Tabellenblätter zugreifen und sich also die Inhalte ab A4 bis O letzte Zeile die ausgefüllt ist kopieren und diese in einem Tabellenblatt die genauso aufgebaut ist wie die anderen auch untereinander lückenlos kopieren.

    Andreas.

    Sub Test()
      Dim Dest As Range, Source As Range
      Dim Ws As Worksheet
      
      'Ziel diese Tabelle nächste freie Zelle in A
      Set Dest = Range("A" & Rows.Count).End(xlUp).Offset(1)
      
      'Durchlaufe alle Blätter
      For Each Ws In Worksheets
        'Unser Blatt übergehen
        If Ws.Name = Dest.Parent.Name Then GoTo Skip
        
        'Quelle festlegen:
        Set Source = Ws.Range("A4", Ws.Range("O" & Rows.Count).End(xlUp))
        'Werte kopieren
        Source.Copy
        Dest.PasteSpecial xlPasteValues
        Application.CutCopyMode = False
        'Ziel weitersetzen
        Set Dest = Dest.Offset(Source.Rows.Count)
    Skip:
      Next
    End Sub

    Dienstag, 9. Januar 2018 11:27

Alle Antworten

  • Hi,

    leider hast Du weder  Code noch sonst irgendwelche für uns hilfreiche Angaben gepostet.

    Poste daher bitte erst mal den Code, dann schauen wir weiter.


    Gruß, Stefan
    Microsoft MVP - Visual Developer ASP/ASP.NET
    http://www.asp-solutions.de/ - Consulting, Development
    http://www.aspnetzone.de/ - ASP.NET Zone, die ASP.NET Community

    Freitag, 5. Januar 2018 13:51
    Moderator
  • Hi,
    also nun haben wir uns darauf geeignet alle Tabellen in einer Excel Datei darzustellen sodass ein Registerblatt auf alle zugreift und sich diese raus kopiert. Jede Tabelle ist gleich aufgebaut die Inhalte sind unterschiedlich groß da es sich um Maßnahmen der jeweiligen Bereiche Handelt und jeder Bereich unterschiedlich viele Maßnahmen hat soll mein Code auf 12 Tabellenblätter zugreifen und sich also die Inhalte ab A4 bis O letzte Zeile die ausgefüllt ist kopieren und diese in einem Tabellenblatt die genauso aufgebaut ist wie die anderen auch untereinander lückenlos kopieren.

    Das ist mein Code den ich momentan habe. Ich hatte noch viele viele andere Versuche aber leider haben die auch nicht funktioniert. Ich bin leider noch ein Anfänger:(

    Sub Import()
    '
    ' Import Makro
    '

    '
        Range("A4:O70").Select
        Selection.Copy
        Application.CutCopyMode = False
        Selection.Copy
        Sheets("Werksumweltprogramm").Select
        Range("A4").Select
        ActiveSheet.Paste
        Range("C10").Select
        Sheets("Umweltprogramm E").Select
        ActiveWindow.ScrollWorkbookTabs Sheets:=-1
        ActiveWindow.ScrollWorkbookTabs Sheets:=-1
        ActiveWindow.ScrollWorkbookTabs Sheets:=-1
        ActiveWindow.ScrollWorkbookTabs Sheets:=-1
        ActiveWindow.ScrollWorkbookTabs Sheets:=-1
        Sheets("Umweltprogramm WL").Select
        ActiveWindow.SmallScroll Down:=-9
        Sheets("Umweltprogramm TIB incl TSFM3").Select
        ActiveWindow.SmallScroll Down:=-45
        Range("A4:O70").Select
        Application.CutCopyMode = False
        Selection.Copy
        Application.WindowState = xlMinimized
        Application.WindowState = xlNormal
        ActiveWindow.SmallScroll Down:=-3
        Sheets("Werksumweltprogramm").Select
        Range("A5").Select
        ActiveSheet.Paste
        Sheets("Umweltprogramm E").Select
        ActiveWindow.ScrollWorkbookTabs Sheets:=-1
        ActiveWindow.ScrollWorkbookTabs Sheets:=-1
        ActiveWindow.ScrollWorkbookTabs Sheets:=-1
        ActiveWindow.ScrollWorkbookTabs Sheets:=-1
        ActiveWindow.ScrollWorkbookTabs Sheets:=-1
        Sheets("Umweltprogramm SC-PTB").Select
        ActiveWindow.SmallScroll Down:=-42
        Range("A4:O70").Select
        Application.CutCopyMode = False
        Selection.Copy
        Sheets("Werksumweltprogramm").Select
        Range("A6").Select
        ActiveSheet.Paste
        Sheets("Umweltprogramm E").Select
        ActiveWindow.SmallScroll Down:=-45
        Range("A4:O70").Select
        Application.CutCopyMode = False
        Selection.Copy
        Sheets("Werksumweltprogramm").Select
        Range("A8").Select
        ActiveSheet.Paste
        Sheets("Umweltprogramm PT-BPN").Select
        ActiveWindow.SmallScroll Down:=-51
        Range("A4:O70").Select
        Application.CutCopyMode = False
        Selection.Copy
        Sheets("Werksumweltprogramm").Select
        Range("A11").Select
        ActiveSheet.Paste
        Sheets("Umweltprogramm PT-BPS").Select
        Range("A4:O70").Select
        Application.CutCopyMode = False
        Selection.Copy
        Sheets("Werksumweltprogramm").Select
        Range("A12").Select
        ActiveSheet.Paste
        Sheets("Umweltprogramm HRM").Select
        ActiveWindow.SmallScroll Down:=-39
        Range("A4:O70").Select
        Application.CutCopyMode = False
        Selection.Copy
        Sheets("Werksumweltprogramm").Select
        Range("A13").Select
        ActiveSheet.Paste
        ActiveWindow.SmallScroll Down:=-3
        Sheets("Umweltprogramm QM-PTB").Select
        ActiveWindow.SmallScroll Down:=-48
        Range("A4:O70").Select
        Application.CutCopyMode = False
        Selection.Copy
        Sheets("Werksumweltprogramm").Select
        Range("A15").Select
        ActiveSheet.Paste
        Sheets("Umweltprogramm QM-PTB").Select
        ActiveWindow.SmallScroll Down:=-39
        Sheets("Umweltprogramm PTB").Select
        ActiveWindow.SmallScroll Down:=-45
        Range("N67:O71").Select
        Range("O71").Activate
        ActiveWindow.SmallScroll Down:=-60
        Range("A4:O70").Select
        Application.CutCopyMode = False
        Selection.Copy
        Sheets("Werksumweltprogramm").Select
        Range("A17").Select
        ActiveSheet.Paste
        Sheets("Umweltprogramm SUM").Select
        Range("A4:O70").Select
        Application.CutCopyMode = False
        Selection.Copy
        Sheets("Werksumweltprogramm").Select
        Range("A19").Select
        ActiveSheet.Paste
        Range("P23").Select
    End Sub

    Bitte helft mir
    LG

    Feyza

    Dienstag, 9. Januar 2018 08:37
  • In der Spalte N habe ich in den einzelnen Registerblättern eine Wenn Funktion eingebaut. Bei diesem Code ist das Problem das wenn ich eben die Inhalte änder er die nicht alle untereinander kopiert UND das er in die Spalte N überall 0 schreibt wobei ich möchte das er die eins zu eins ohne Formel übernimmt
    Dienstag, 9. Januar 2018 08:47
  • jetzt habe ich das Makro neu gemacht jedoch brauche ich immer noch das, dass er erkennt in welche nächste Zeile er kopiert sodass alle Maßnahmen untereinander stehen

    Sub Import()
    '
    ' Import Makro
    ' Import der Bereichsumweltprogramme
    '

    '
        Range("A4:O150").Select
        Selection.ClearContents
        ActiveWindow.ScrollWorkbookTabs Sheets:=-1
        ActiveWindow.ScrollWorkbookTabs Sheets:=-1
        ActiveWindow.ScrollWorkbookTabs Sheets:=-1
        ActiveWindow.ScrollWorkbookTabs Sheets:=-1
        ActiveWindow.ScrollWorkbookTabs Sheets:=-1
        ActiveWindow.ScrollWorkbookTabs Sheets:=-1
        Sheets("Umweltprogramm WL").Select
        Selection.Copy
        Sheets("Werksumweltprogramm").Select
        Range("A4").Select
        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
            :=False, Transpose:=False
        ActiveWindow.ScrollWorkbookTabs Sheets:=-1
        ActiveWindow.ScrollWorkbookTabs Sheets:=-1
        ActiveWindow.ScrollWorkbookTabs Sheets:=-1
        ActiveWindow.ScrollWorkbookTabs Sheets:=-1
        ActiveWindow.ScrollWorkbookTabs Sheets:=-1
        ActiveWindow.ScrollWorkbookTabs Sheets:=-1
        Sheets("Umweltprogramm TIB incl TSFM3").Select
        Application.CutCopyMode = False
        Selection.Copy
        Sheets("Werksumweltprogramm").Select
        Range("A5").Select
        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
            :=False, Transpose:=False
        ActiveWindow.ScrollWorkbookTabs Sheets:=-1
        ActiveWindow.ScrollWorkbookTabs Sheets:=-1
        ActiveWindow.ScrollWorkbookTabs Sheets:=-1
        ActiveWindow.ScrollWorkbookTabs Sheets:=-1
        ActiveWindow.ScrollWorkbookTabs Sheets:=-1
        ActiveWindow.ScrollWorkbookTabs Sheets:=-1
        Sheets("Umweltprogramm SC-PTB").Select
        ActiveWindow.SmallScroll Down:=-18
        Application.CutCopyMode = False
        Selection.Copy
        Sheets("Werksumweltprogramm").Select
        Range("A6").Select
        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
            :=False, Transpose:=False
        ActiveWindow.ScrollWorkbookTabs Sheets:=-1
        ActiveWindow.ScrollWorkbookTabs Sheets:=-1
        ActiveWindow.ScrollWorkbookTabs Sheets:=-1
        ActiveWindow.ScrollWorkbookTabs Sheets:=-1
        ActiveWindow.ScrollWorkbookTabs Sheets:=-1
        Sheets("Umweltprogramm FP").Select
        ActiveWindow.SmallScroll Down:=-45
        Range("A4:O70").Select
        Application.CutCopyMode = False
        Selection.Copy
        Sheets("Werksumweltprogramm").Select
        Range("A8").Select
        ActiveSheet.Paste
        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
            :=False, Transpose:=False
        ActiveWindow.ScrollWorkbookTabs Sheets:=-1
        ActiveWindow.ScrollWorkbookTabs Sheets:=-1
        Sheets("Umweltprogramm E").Select
        Application.CutCopyMode = False
        Selection.Copy
        Sheets("Werksumweltprogramm").Select
        Range("A11").Select
        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
            :=False, Transpose:=False
        ActiveWindow.ScrollWorkbookTabs Sheets:=-1
        Sheets("Umweltprogramm PT-BPN").Select
        Application.CutCopyMode = False
        Selection.Copy
        Sheets("Werksumweltprogramm").Select
        Range("A14").Select
        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
            :=False, Transpose:=False
        Sheets("Umweltprogramm PT-BPS").Select
        Application.CutCopyMode = False
        Selection.Copy
        Sheets("Werksumweltprogramm").Select
        Range("A15").Select
        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
            :=False, Transpose:=False
        Sheets("Umweltprogramm HRM").Select
        Application.CutCopyMode = False
        Selection.Copy
        Sheets("Werksumweltprogramm").Select
        Range("A20").Select
        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
            :=False, Transpose:=False
        Sheets("Umweltprogramm QM-PTB").Select
        Application.CutCopyMode = False
        Selection.Copy
        Sheets("Werksumweltprogramm").Select
        Range("A25").Select
        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
            :=False, Transpose:=False
        Sheets("Umweltprogramm PTB").Select
        Application.CutCopyMode = False
        Selection.Copy
        Sheets("Werksumweltprogramm").Select
        Range("A27").Select
        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
            :=False, Transpose:=False
        Sheets("Umweltprogramm SUM").Select
        Application.CutCopyMode = False
        Selection.Copy
        Sheets("Werksumweltprogramm").Select
        Range("A29").Select
        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
            :=False, Transpose:=False
        Range("A4:O150").Select
        Application.CutCopyMode = False
        Selection.Borders(xlDiagonalDown).LineStyle = xlNone
        Selection.Borders(xlDiagonalUp).LineStyle = xlNone
        With Selection.Borders(xlEdgeLeft)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlThin
        End With
        With Selection.Borders(xlEdgeTop)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlThin
        End With
        With Selection.Borders(xlEdgeBottom)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlThin
        End With
        With Selection.Borders(xlEdgeRight)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlThin
        End With
        With Selection.Borders(xlInsideVertical)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlThin
        End With
        With Selection.Borders(xlInsideHorizontal)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlThin
        End With
    End Sub

    Dienstag, 9. Januar 2018 08:57
  • und leider kopiert er nach Änderung nicht alles vollständig...:(
    Dienstag, 9. Januar 2018 09:00
  • Hi, meiner Meinung nach wirst du mit dem aufnehmen von Makros nicht zum Ziel gelangen. 

    Als erstes solltest du die erste freie Zelle in deinem Ziel-Tabellenblatt ermitteln. Das ist eigentlich recht einfach:

    Sub SucheFreieZelle()
    Dim Zelle As Range
    Dim Maxzeile As Long
    
        If Val(Left(Application.Version, 2)) > 11 Then
            Maxzeile = 1048576
        Else
            Maxzeile = 65536
        End If
        Set Zelle = Cells(Maxzeile, 1).End(xlUp).Offset(1, 0)
        MsgBox "Die nächste freie Zelle ist " & Zelle.Address(False, False)
    End Sub

    Das muss natürlich noch für deine Bedürfnisse angepasst werden. Eine Funktion wäre sich gut, da du es ja öfter brauchst.

    Hier mal eine (fertige) Funktion:

    Function ErsteLeereZeile(Sp As Variant) As Long
    ' Zelle mit Inhalt "" zählt NICHT als leer
       Dim rngData As Range, Zelle1 As Range, c As Range
       Dim lRow As Long, AnzLeer As Long
       Dim Rc As Long
      
       On Error GoTo ErrorHandler
       If VarType(Sp) = vbString Then Sp = Columns(Sp).Column
       With ActiveSheet
          Set Zelle1 = .Cells(1, Sp)
          lRow = .Cells(Rows.Count, Sp).End(xlUp).Row
          Set rngData = .Range(Zelle1, .Cells(lRow, Sp))
          AnzLeer = rngData.Rows.Count - WorksheetFunction.Count(rngData)
          
          Do
             'Zeile 1 ist leer aber nicht ""
             If VarType(Zelle1) = 0 Then
                Rc = 1
                Exit Do
             End If
            
             Set c = Zelle1
             If lRow > 1 Then
                Do
                   Set c = c.End(xlDown)
                   If VarType(c.Offset(1, 0)) = 0 Then
                      Rc = c.Row + 1
                      Exit Do
                   End If
                Loop
             Else  'lRow = 1
                Rc = 2
                
             End If
             Exit Do
          Loop
       End With
          
    ErrorHandler:
       If Err.Number <> 0 Then
          MsgBox "Fehler Nr. " & Err.Number & vbCrLf & Err.Description
          Rc = 1 'Um einen undefinierten Zustand zu vermeiden
       End If
       ErsteLeereZeile = Rc
    End Function

    Als nächstes brauchst du eine ähnliche Funktion, welche den Bereich in deinem Quell-Tabellenblatt sucht, den du kopieren möchtest.

    Dann hast du Ziel und Quelle und kannst kopieren. Das wiederholst du dann so oft, bis deine Daten zusammen sind.

    Ich habe leider nicht durchgehend Zeit heute, deshalb kann es ein bisschen dauern, bis ich dir ein Beispiel zusammenbastele.

    Gruß


    Freiberufler im Bereich Softwareentwicklung Von der PLC und Robotik zu VB.NET & C#, vorrangig WPF und UWP


    Dienstag, 9. Januar 2018 10:45
  • Als nächstes brauchst du eine ähnliche Funktion, welche den Bereich in deinem Quell-Tabellenblatt sucht, den du kopieren möchtest.

    Warum so kompliziert?

    Die Aufgabe ist doch klar gegeben:
    soll mein Code auf 12 Tabellenblätter zugreifen und sich also die Inhalte ab A4 bis O letzte Zeile die ausgefüllt ist kopieren und diese in einem Tabellenblatt die genauso aufgebaut ist wie die anderen auch untereinander lückenlos kopieren.

    Andreas.

    Sub Test()
      Dim Dest As Range, Source As Range
      Dim Ws As Worksheet
      
      'Ziel diese Tabelle nächste freie Zelle in A
      Set Dest = Range("A" & Rows.Count).End(xlUp).Offset(1)
      
      'Durchlaufe alle Blätter
      For Each Ws In Worksheets
        'Unser Blatt übergehen
        If Ws.Name = Dest.Parent.Name Then GoTo Skip
        
        'Quelle festlegen:
        Set Source = Ws.Range("A4", Ws.Range("O" & Rows.Count).End(xlUp))
        'Werte kopieren
        Source.Copy
        Dest.PasteSpecial xlPasteValues
        Application.CutCopyMode = False
        'Ziel weitersetzen
        Set Dest = Dest.Offset(Source.Rows.Count)
    Skip:
      Next
    End Sub

    Dienstag, 9. Januar 2018 11:27