Anzeige
Archiv - Navigation
1276to1280
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

@Sepp

@Sepp
Claudia
Hallo Sepp,
ich brauche nach längerer Zeit wieder Deine Hilfe.
Ich muss aus verschiedenen Reitern Daten zusammentragen. Der Aufbau der Reiter ist immer gleich.
Genauer gesagt, soll aus allen roten Reitern der Zellinhalt aus dem Bereich B7: F300 in eine neue Tabelle zusammengetragen werden. Die neue Tabelle soll so aufgebaut sein.
Überschiften
A1 = Datum
B1 = Code
C1 = Text
D1 = Buchung
E1 = Bestand
Ab Zeile 2 soll jeweils der Zellinhalt (Wert) eingefügt werden. Leere Zellen sollen anschliessend in dieser neuen Tabelle gelöscht werden. Der Rest soll nach dem Datum (Spalte A) sortiert werden.
Gut wäre es, wenn ich den Bereich B7:F300 leicht selbst verändern kann (sowohl Zeilen- als auch Spaltenangabe).
Kannst Du mir helfen? Vielen lieben Dank!
Liebe Grüße
Claudia

5
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Benutzer
Anzeige
AW: @Sepp
25.08.2012 14:32:24
Josef

Hallo Claudia,
es freut mich, dass du mich suchst;-))
Aber du solltest Fragen an die Allgemeinheit stellen, dann sind die Chancen auf Antwort größer.
Teste mal.
Sub claudia()
  Dim objSh As Worksheet, objNew As Worksheet
  Dim lngRow As Long, lngCalc As Long
  
  Const cstrRange As String = "B7:F300"
  
  On Error GoTo ErrExit
  
  With Application
    .ScreenUpdating = False
    .EnableEvents = False
    lngCalc = .Calculation
    .Calculation = xlCalculationManual
    .DisplayAlerts = False
  End With
  
  lngRow = 2
  
  Set objNew = Worksheets.Add(After:=Sheets(Sheets.Count))
  
  With objNew
    .Name = "Zusammenfassung-" & Format(Now, "yyMMdd hhmmss")
    .Range("A1:E1") = Array("Datum", "Code", "Text", "Buchung", "Bestand")
    .Rows(1).Font.Bold = True
    
    For Each objSh In ThisWorkbook.Worksheets
      If objSh.Tab.ColorIndex = 3 Then
        objSh.Range(cstrRange).Copy .Cells(lngRow, 1)
        lngRow = lngRow + 294
      End If
    Next
    .Range("A1").Resize(lngRow, .Range(cstrRange).Columns.Count).Sort _
      Key1:=.Range("A1"), Order1:=xlAscending, Header:=xlYes
  End With
  
  ErrExit:
  
  With Err
    If .Number <> 0 Then
      MsgBox "Fehler in Prozedur:" & vbTab & "'claudia'" & vbLf & String(60, "_") & _
        vbLf & vbLf & IIf(Erl, "Fehler in Zeile:" & vbTab & Erl & vbLf & vbLf, "") & _
        "Fehlernummer:" & vbTab & .Number & vbLf & vbLf & "Beschreibung:" & vbTab & _
        .Description & vbLf, vbExclamation + vbMsgBoxSetForeground, _
        "VBA - Fehler in Modul - Modul2"
      .Clear
    End If
  End With
  
  On Error GoTo 0
  
  With Application
    .ScreenUpdating = True
    .EnableEvents = True
    .Calculation = lngCalc
    .DisplayAlerts = True
    .StatusBar = False
  End With
  
  Set objNew = Nothing
  Set objSh = Nothing
End Sub



« Gruß Sepp »

Anzeige
AW: @Sepp
25.08.2012 16:41:14
Claudia
Hallo Sepp,
ja, Du bist ja der Beste. Immer hilfsbereit und die Lösungen sind top. ;-)
Habe Dein Makro ausprobiert. Funktioniert - allerdings werden auch Formeln kopiert. Kannst Du es so ändern, dass nur der Wert kopiert wird. Die Formlen laufen nämlich ins Leere.
Vielen lieben Dank!
Liebe Grüße
Claudia

AW: @Sepp
25.08.2012 16:45:27
Josef

Hallo Claudia,
kein Problem.
Sub claudia()
  Dim objSh As Worksheet, objNew As Worksheet
  Dim lngRow As Long, lngCalc As Long
  
  Const cstrRange As String = "B7:F300"
  
  On Error GoTo ErrExit
  
  With Application
    .ScreenUpdating = False
    .EnableEvents = False
    lngCalc = .Calculation
    .Calculation = xlCalculationManual
    .DisplayAlerts = False
  End With
  
  lngRow = 2
  
  Set objNew = Worksheets.Add(After:=Sheets(Sheets.Count))
  
  With objNew
    .Name = "Zusammenfassung-" & Format(Now, "yyMMdd hhmmss")
    .Range("A1:E1") = Array("Datum", "Code", "Text", "Buchung", "Bestand")
    .Rows(1).Font.Bold = True
    
    For Each objSh In ThisWorkbook.Worksheets
      If objSh.Tab.ColorIndex = 3 Then
        .Cells(lngRow, 1).Resize(Range(cstrRange).Rows.Count, Range(cstrRange).Columns.Count) = objSh.Range(cstrRange).Value
        lngRow = lngRow + 294
      End If
    Next
    .Range("A1").Resize(lngRow, .Range(cstrRange).Columns.Count).Sort _
      Key1:=.Range("A1"), Order1:=xlAscending, Header:=xlYes
  End With
  
  ErrExit:
  
  With Err
    If .Number <> 0 Then
      MsgBox "Fehler in Prozedur:" & vbTab & "'claudia'" & vbLf & String(60, "_") & _
        vbLf & vbLf & IIf(Erl, "Fehler in Zeile:" & vbTab & Erl & vbLf & vbLf, "") & _
        "Fehlernummer:" & vbTab & .Number & vbLf & vbLf & "Beschreibung:" & vbTab & _
        .Description & vbLf, vbExclamation + vbMsgBoxSetForeground, _
        "VBA - Fehler in Modul - Modul2"
      .Clear
    End If
  End With
  
  On Error GoTo 0
  
  With Application
    .ScreenUpdating = True
    .EnableEvents = True
    .Calculation = lngCalc
    .DisplayAlerts = True
    .StatusBar = False
  End With
  
  Set objNew = Nothing
  Set objSh = Nothing
End Sub



« Gruß Sepp »

Anzeige
@Sepp: Funktioniert super - danke! ;-)
25.08.2012 17:01:12
Claudia

@Claudia, kleine anpassung
26.08.2012 12:34:14
Josef

Hallo Claudia,
diese Zeile
lngRow = lngRow + 294

solltest du ändern in
lngRow = lngRow + Range(cstrRange).Rows.Count

damit beim Anpassen des Bereiches richtig eingefügt wird.

« Gruß Sepp »

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige