Bereich mit Start und Endpunkt kopieren

Hallo Zusammen,
ich bin auf der Suche nach einer kleinen VBA Lösung zum kopieren eines Bereichs.
Hintergrund:
Ich möchte einen Bereich kopieren, der einen definierten Anfangs- und Endpunkt hat. (Immer Spalte A).Da immer wieder Zeilen dazukommen können, möchte ich gerne mit Cells.Find nach dem Start- und Endpunkt suchen. Sagen wir der Startpunkt heisst "Interne Fertigung" und der Endpunkt "Externe Fertigung". Der Bereich dazwischen soll kopiert werden und in ein neues Tabellenblatt eingefügt werden. Dadurch hätte ich dann die Anzahl an Zeilen definiert. Die Spaltenanzahl könnte ich erstmal fest definieren, toll wäre es natürlich so viele Spalten zu kopieren wie Werte darin enthalten sind.
Letzter Knackpunkt ist, dass die Daten aus einer anderen Exceldatei kommen und daher importiert werden sollen.
Vielen Dank für eure Hilfe!
BG!
Kevin

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Nachfrage..

13.03.2018 11:38:29

UweD

AW: Nachfrage..

13.03.2018 12:51:17

UweD

angenommen das makro ist in der Datei, aus der die Daten überetragen werden sollen, und diese ist offen...

Sub Bereich()
    Dim Anfang As String, Endpunkt As String
    Dim WB1 As Workbook, WB2 As Workbook, TB1 As Worksheet, TB2 As Worksheet
    Dim SP As Integer, LC As Integer, AZ As Double, EZ As Double
    Dim RNG As String
    
    Set WB1 = ThisWorkbook
    Set TB1 = WB1.Sheets("Tabelle1")
    SP = 1 'aus Spalte A 
    
    RNG = "A1" 'Zielzelle 
    
    LC = TB1.Cells(1, TB1.Columns.Count).End(xlToLeft).Column 'letzte Spalte von Zeile 1 
    
    
    Anfang = "Interne Fertigung"
    Endpunkt = "Externe Fertigung"
    
    With WorksheetFunction
        If .CountIf(TB1.Columns(SP), Anfang) > 0 Then
            AZ = .Match(Anfang, TB1.Columns(SP), 0)
        Else
            MsgBox "Datenfehler: '" & Anfang & "' nicht gefunden"
            Exit Sub
        End If
    
        If .CountIf(TB1.Columns(SP), Endpunkt) > 0 Then
            EZ = .Match(Endpunkt, TB1.Columns(SP), 0)
        Else
            MsgBox "Datenfehler: '" & Endpunkt & "' nicht gefunden"
            Exit Sub
        End If
    End With
    
    If EZ < AZ Then MsgBox "Fehler: Reihenfolge": Exit Sub
    
    Workbooks.Add
    Set WB2 = ActiveWorkbook
    Set TB2 = WB2.Sheets(1)
    
    
    TB1.Cells(AZ, 1).Resize(EZ - AZ + 1, LC).Copy TB2.Range(RNG)
    
End Sub

LG UweD

Beliebteste Forumthreads (12 Monate)

Bereich mit Start und Endpunkt kopieren

2 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

2
Beiträge zum Forumthread

Beiträge zu diesem Forumthread