@Josef Ehrensberger VBA Suchen-Kopieren

Hallo Josef Ehrensberger,
richte mein Anliegen an dich, da du auch auf mein Anliegen:
an Klaus geantowrtet hast, dieser sich aber leider nicht mehr meldet und ich selber diese Routine nicht zustande bringe. Vielleicht kannst du mir erfolgreich behilflich sein. Ich habe 8 identische Mappen mit 12 Monatsregistern, jedoch unterscheiden sich die Mappen in der Zeilenanzahl und jede Mappe hat andere Begriffe in Spalte 3. Beispiel upgeloaded:
https://www.herber.de/bbs/user/30336.xls
Ich hätte gerne ein script, bei dem eine Tabelle angehängt wird und in jedem Monatsregister die Spalten 15 bis 76 durchforstet werden und bei finden die ganze Spalte dann im neuen sheet anhängt. Der Begriff aus Spalte 3 aus dem Monatsregister 01 sollte im neuen sheet in Spalte 1, die gefundenen und angehängt kopierten Spalten fortlaufen angesetzt werden. Ist das so machbar und könntest du mir bitte helfen? (In der jeweiligen 1. Datumsspalte wird immer bei erledigung ein kleines "x" eingetragen, in der 2. Datumsspalte nur ganze Zahlen. Die Zahlenspalten könnten unberücksichtigt bleiben. Benötigt werden praktisch nur immer die x-Spalten - so bekäme man auf ein sheet gerade ein ganzes Jahr (bei jedem Tag ohne Wochenenden ohne Feiertage)
Vielleicht kannst du dich des Problems annehmen?
Erst einmal danke und Gruß
Horst

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo Horst!
Ich hab es mir doch angetan;-))
Allerdings nehme ich an, das die doppelten Objektnummern nur in der Beispieldatei
vorkommen. Wenn nicht, dann sorry, aber das bau ich wirklich nicht mehr ein.
Kopiere den Code in ein leere Standardmodul und los geht's.

' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Sub zusammenfassung()
Dim objShZ As Worksheet, objSh As Worksheet
Dim intIndex As Integer, intCol As Integer, intLastCol As Integer
Dim lngRow As Long, lngLastRow As Long, lngNew As Long
Dim rngFind As Range

On Error Resume Next

Set objShZ = Sheets("Zusammenfassung")

If objShZ Is Nothing Then
  Set objShZ = Worksheets.Add(after:=Sheets(Sheets.Count))
  With objShZ
    .Name = "Zusammenfassung"
    .Cells(2, 1) = "ObjektNr."
    .Cells(2, 2) = "Objekt"
    With .Rows("2:2")
      .Borders(xlDiagonalDown).LineStyle = xlNone
      .Borders(xlDiagonalUp).LineStyle = xlNone
      With .Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
      End With
      With .Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
      End With
      With .Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
      End With
      With .Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
      End With
      With .Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
      End With
    End With
  End With
  Err.Clear
End If

On Error GoTo ErrExit
objShZ.Range("C2:IV2").ClearContents
objShZ.Range("C3:IV65536").Clear
objShZ.Activate
With Application
  .ScreenUpdating = False
  .EnableEvents = False
  .DisplayAlerts = False
  .Calculation = xlCalculationManual
  .Cursor = xlWait
End With

For intIndex = 1 To 12

  Set objSh = Sheets(Format(intIndex, "00"))

  Application.StatusBar = "Importiere: " & Format(DateSerial(1, intIndex, 1), "mmmm") & ", Bitte warten...."

  With objSh
    lngLastRow = .Cells(Rows.Count, 3).End(xlUp).Row

    intLastCol = 15 + Day(DateSerial(Year(Date), intIndex + 1, -1)) * 2

    For intCol = 15 To intLastCol Step 2
      If Weekday(.Cells(2, intCol), vbMonday) < 6 Then
        If Application.CountA(.Range(.Cells(3, intCol), .Cells(lngLastRow, intCol))) > 0 Then
          objShZ.Cells(2, objShZ.Cells(2, Columns.Count).End(xlToLeft).Column + 1) = .Cells(2, intCol).Text
          For lngRow = 3 To lngLastRow
            If .Cells(lngRow, intCol) <> "" Then

              Set rngFind = objShZ.Range("A:A").Find(.Cells(lngRow, 2), lookat:=xlWhole)

              If Not rngFind Is Nothing Then
                .Cells(lngRow, intCol).Copy objShZ.Cells(rngFind.Row, objShZ.Cells(2, Columns.Count).End(xlToLeft).Column)
              Else
                lngNew = objShZ.Cells(Rows.Count, 1).End(xlUp).Row + 1
                objShZ.Cells(lngNew, 1) = .Cells(lngRow, 2)
                objShZ.Cells(lngNew, 2) = .Cells(lngRow, 3)
                .Cells(lngRow, intCol).Copy objShZ.Cells(lngNew, objShZ.Cells(2, Columns.Count).End(xlToLeft).Column)
              End If

            End If
          Next

        End If
      End If
    Next

  End With
  Set objSh = Nothing
Next

objShZ.Columns.AutoFit

ErrExit:

Set objShZ = Nothing

With Application
  .StatusBar = False
  .ScreenUpdating = True
  .EnableEvents = True
  .DisplayAlerts = True
  .Calculation = xlCalculationAutomatic
  .Cursor = xlDefault
End With

End Sub

'******************************
'* Gruß Sepp
'*
'* Rückmeldung wäre nett!
'******************************

Beliebteste Forumthreads (12 Monate)

@Josef Ehrensberger VBA Suchen-Kopieren

6 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

6
Beiträge zum Forumthread

Beiträge zu diesem Forumthread