Tabelleninhalt nach Spalteneintrag aufteilen

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo Fritz!
Kopiere den Code in ein allgemeines Modul deiner Datei.

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

Option Explicit

Sub CopyA_B()
Dim objShSrc As Worksheet, objShTar As Worksheet
Dim rng As Range, rngCopy As Range
Dim strFirst As String, strMessage As String
Dim varSearch As Variant
Dim intIndex As Integer
Dim lngNext As Long

On Error GoTo ErrExit
GetMoreSpeed

varSearch = Array("A", "B") 'Suchbegriffe/Tabellennamen

Set objShSrc = Sheets("Jahr") 'Tabelle mit Daten

For intIndex = 0 To UBound(varSearch)

  Set rngCopy = Nothing
  strFirst = ""

  If Not SheetExist(varSearch(intIndex)) Then
    Set objShTar = Worksheets.Add(After:=Sheets(Sheets.Count))
    objShTar.Name = varSearch(intIndex)

    With objShSrc

      Set rng = .Range("D:D").Find(what:=varSearch(intIndex), LookAt:=xlWhole, After:=.Range("D" & Rows.Count))

      If Not rng Is Nothing Then
        strFirst = rng.Address

        Do

          If rngCopy Is Nothing Then
            Set rngCopy = Union(.Cells(rng.Row, 3), .Cells(rng.Row, 6), .Cells(rng.Row, 19))
          Else
            Set rngCopy = Union(rngCopy, .Cells(rng.Row, 3), .Cells(rng.Row, 6), .Cells(rng.Row, 19))
          End If

          Set rng = .Range("D:D").FindNext(rng)

        Loop While Not rng Is Nothing And rng.Address <> strFirst

      End If

      If Not rngCopy Is Nothing Then
        lngNext = objShTar.Cells(Rows.Count, 3).End(xlUp).Row + 1
        If lngNext < 4 Then lngNext = 4
        rngCopy.Copy objShTar.Cells(lngNext, 3)
      End If

    End With

  Else

    strMessage = strMessage & varSearch(intIndex) & vbLf

  End If

Next

If strMessage <> "" Then
  MsgBox "Die Tabelle(n)" & Space(75) & vbLf & vbLf & _
    strMessage & vbLf & vbLf & "existierte(n) bereits!" & vbLf & vbLf & _
    "Die entsprechenden Daten wurden NICHT kopiert!", 64, "Hinweis"
Else
  MsgBox "Die Daten wurden erfolgreich kopiert!", 64, "Hinweis"
End If

ErrExit:
GetMoreSpeed 0
Set objShSrc = Nothing
Set objShTar = Nothing
Set rng = Nothing
Set rngCopy = Nothing
End Sub

Private Function SheetExist(ByVal sheetName As String, Optional WbName As String) As Boolean
Dim wks As Worksheet
On Error GoTo ERRORHANDLER
If WbName = "" Then WbName = ThisWorkbook.Name
For Each wks In Workbooks(WbName).Worksheets
  If wks.Name = sheetName Then SheetExist = True: Exit Function
Next
ERRORHANDLER:
SheetExist = False
End Function

Sub GetMoreSpeed(Optional ByVal Modus As Integer = 1)
Static lngCalc As Long

With Application
  If Modus = 1 Then
    lngCalc = .Calculation
    .ScreenUpdating = False
    .EnableEvents = False
    .DisplayAlerts = False
    .Calculation = -4135
    .Cursor = xlWait
  Else
    .ScreenUpdating = True
    .EnableEvents = True
    .DisplayAlerts = True
    .Calculation = IIf(lngCalc <> 0, lngCalc, -4105)
    .Cursor = xlDefault
  End If
End With

End Sub

Gruß Sepp

Hallo Fritz!
Dann so.

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

Option Explicit

Sub CopyA_B()
Dim objShSrc As Worksheet, objShTar As Worksheet
Dim rng As Range, rngCopy As Range
Dim strFirst As String, strMessage As String
Dim varSearch As Variant
Dim intIndex As Integer
Dim lngNext As Long

On Error GoTo ErrExit
GetMoreSpeed

varSearch = Array("A", "B") 'Suchbegriffe/Tabellennamen

Set objShSrc = Sheets("Jahr") 'Tabelle mit Daten

For intIndex = 0 To UBound(varSearch)

  Set rngCopy = Nothing
  strFirst = ""

  If Not SheetExist(varSearch(intIndex)) Then
    Set objShTar = Worksheets.Add(After:=Sheets(Sheets.Count))
    objShTar.Name = varSearch(intIndex)

    With objShSrc

      Set rng = .Range("D:D").Find(what:=varSearch(intIndex), _
        LookAt:=xlWhole, _
        LookIn:=xlValues, _
        After:=.Range("D" & Rows.Count))

      If Not rng Is Nothing Then
        strFirst = rng.Address

        Do

          If rngCopy Is Nothing Then
            Set rngCopy = Union(.Cells(rng.Row, 3), .Cells(rng.Row, 6), .Cells(rng.Row, 19))
          Else
            Set rngCopy = Union(rngCopy, .Cells(rng.Row, 3), .Cells(rng.Row, 6), .Cells(rng.Row, 19))
          End If

          Set rng = .Range("D:D").FindNext(rng)

        Loop While Not rng Is Nothing And rng.Address <> strFirst

      End If

      If Not rngCopy Is Nothing Then
        lngNext = objShTar.Cells(Rows.Count, 3).End(xlUp).Row + 1
        If lngNext < 4 Then lngNext = 4
        rngCopy.Copy
        objShTar.Cells(lngNext, 3).PasteSpecial xlValues
        Application.CutCopyMode = False
      End If

    End With

  Else

    strMessage = strMessage & varSearch(intIndex) & vbLf

  End If

Next

If strMessage <> "" Then
  MsgBox "Die Tabelle(n)" & Space(75) & vbLf & vbLf & _
    strMessage & vbLf & vbLf & "existierte(n) bereits!" & vbLf & vbLf & _
    "Die entsprechenden Daten wurden NICHT kopiert!", 64, "Hinweis"
Else
  MsgBox "Die Daten wurden erfolgreich kopiert!", 64, "Hinweis"
End If

ErrExit:
GetMoreSpeed 0
Set objShSrc = Nothing
Set objShTar = Nothing
Set rng = Nothing
Set rngCopy = Nothing
End Sub

Private Function SheetExist(ByVal sheetName As String, Optional WbName As String) As Boolean
Dim wks As Worksheet
On Error GoTo ERRORHANDLER
If WbName = "" Then WbName = ThisWorkbook.Name
For Each wks In Workbooks(WbName).Worksheets
  If wks.Name = sheetName Then SheetExist = True: Exit Function
Next
ERRORHANDLER:
SheetExist = False
End Function

Sub GetMoreSpeed(Optional ByVal Modus As Integer = 1)
Static lngCalc As Long

With Application
  If Modus = 1 Then
    lngCalc = .Calculation
    .ScreenUpdating = False
    .EnableEvents = False
    .DisplayAlerts = False
    .Calculation = -4135
    .Cursor = xlWait
  Else
    .ScreenUpdating = True
    .EnableEvents = True
    .DisplayAlerts = True
    .Calculation = IIf(lngCalc <> 0, lngCalc, -4105)
    .Cursor = xlDefault
  End If
End With

End Sub

Gruß Sepp

Beliebteste Forumthreads (12 Monate)

Tabelleninhalt nach Spalteneintrag aufteilen

9
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

312 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Tabelleninhalt nach Spalteneintrag aufteilen

9 Beiträge zum Forumthread Beiträge zu diesem Forumthread

312 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

9
Beiträge zum Forumthread

Beiträge zu diesem Forumthread