Daten transportieren

Dieter.G · 2015-01-27T17:51:59+00:00

Hallo zusammen, ich brächte wieder mal Eure Hilfe. Ich habe 12 Tabellenblätter (Tabelle21-Tabelle33) in den SpaltenD wird ein bestimmter "Text" eingegeben und in den SpaltenQ wird nur "ja" eingetragen. Jetzt möchte ich mit einem Makro sämtliche Tabellenblätter durchsuchen und immer wenn der "Text" und "ja" in einer Zeile vorhanden sind, die Daten aus den Nachbarzellen G, H, I, M, N der betreffenden Zeile in ein separates Tabellenblatt (Tabelle1) in die Spalten A, B, C, D, E transportiert lassen. Danke schon mal im Voraus und Gruß Dieter

Hallo,
ok. versuch es mal hiermit

Sub Kopieren()
Dim i%
Dim lngRow&
Dim rng As Range, rngErg As Range, rngHelp As Range

For i = 21 To 33
    With Worksheets("Tabelle" & i)
        lngRow = .Cells(.Rows.Count, 17).End(xlUp).Row
        If lngRow > 15 Then
            'Daten Suchen ******************** 
            Set rng = .Range("A16", .Cells(lngRow, 1)).EntireRow
            Set rngHelp = rng.Columns(.Columns.Count)
            rngHelp.FormulaR1C1 = "=IF(AND(RC4<>"""",RC17=""ja""),1,"""")"
            If Application.WorksheetFunction.CountIf(rngHelp, 1) > 0 Then
                Set rngErg = rngHelp.SpecialCells(xlCellTypeFormulas, 1)
            End If
            
            
            'Ausgabe ************************** 
            If Not rngErg Is Nothing Then
                With Tabelle1
                    For Each rngErg In rngErg.Areas
                        With .Cells(.Rows.Count, 4).End(xlUp).Offset(1, -3)
                            rngErg.EntireRow.Columns(7).Resize(, 3).Copy .Resize(, 4)
                            rngErg.EntireRow.Columns(12).Resize(, 2).Copy .Offset(, 3).Resize(, 2)
                        End With
                    Next rngErg
                End With
                rngHelp.EntireColumn.Delete
                Set rngErg = Nothing
            End If
        End If
    End With
Next i
End Sub

Gruß Tino

Hallo,
könnte so gehen.
PS: Warum antwortest du eigentlich immer auf Deinen letzten Beitrag?

Sub Kopieren()
Dim i%
Dim lngRow&
Dim rng As Range, rngErg As Range, rngHelp As Range
Dim oWS As Worksheet

For i = 21 To 23
    For Each oWS In ThisWorkbook.Worksheets
        If oWS.CodeName = "Tabelle" & i Then
            With oWS
                lngRow = .Cells(.Rows.Count, 17).End(xlUp).Row
                If lngRow > 15 Then
                    'Daten Suchen ******************** 
                    Set rng = .Range("A16", .Cells(lngRow, 1)).EntireRow
                    Set rngHelp = rng.Columns(.Columns.Count)
                    rngHelp.FormulaR1C1 = "=IF(AND(RC4<>"""",RC17=""ja""),1,"""")"
                    If Application.WorksheetFunction.CountIf(rngHelp, 1) > 0 Then
                        Set rngErg = rngHelp.SpecialCells(xlCellTypeFormulas, 1)
                    End If
                    
                    
                    'Ausgabe ************************** 
                    If Not rngErg Is Nothing Then
                        With Tabelle1
                            For Each rngErg In rngErg.Areas
                                With .Cells(.Rows.Count, 4).End(xlUp).Offset(1, -3)
                                    rngErg.EntireRow.Columns(7).Resize(, 3).Copy .Resize(, 4)
                                    rngErg.EntireRow.Columns(12).Resize(, 2).Copy .Offset(, 3).Resize(, 2)
                                End With
                            Next rngErg
                        End With
                        rngHelp.EntireColumn.Delete
                        Set rngErg = Nothing
                    End If
                End If
            End With
        End If
    Next oWS
Next i
End Sub

Gruß Tino

Forumthread: Daten transportieren

15
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Daten transportieren

Forumthread: Daten transportieren

15 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

15
Beiträge zum Forumthread

Beiträge zu diesem Forumthread