Office: (Office 2010) Visual Basic Code anpassen

Tag zusammen,

ich habe folgendes vor.

Ich habe 2 Tabellenblätter, Tabelle1 und Tabelle2.
Ich möchte in Tabelle1 in Spalte A nach dem String "8.8" suchen lassen und dann die entsprechenden Zeilen komplett nach Tabelle 2 kopieren. Das klappt mit meinem Code soweit gut.

Ich möchte aber zusätzlich noch, das die Zeilen 1+2 aus Tabelle1 generell in die Spalten 1+2 von Tabelle 2 kopiert werden. Ab A3 von Tabelle2 sollen dann die "String-Zeilen" eingefügt werden.

Außerdem sollen die Breiten der zu kopierenden Zellen aus Tabelle1 genau so in Tabelle2 übernommen werden.

Ich hoffe Ihr könnt mir hierbei helfen meinen Code anzupassen :D

Mein Code:

Code:

Sub kopieren()
Dim lRow As Long, i As Long
Dim wks As Worksheet
Dim c As Range
Dim firstaddress As String
Application.ScreenUpdating = False

Worksheets("Tabelle2").Visible = True 'einblenden
Set wks = Worksheets("Tabelle1")

With wks.Range("a1:G" & wks.Cells(Rows.Count, 2).End(xlUp).Row)
    Set c = .Find(what:="8.8", LookIn:=xlValues, lookat:=xlPart)
    If Not c Is Nothing Then
        firstaddress = c.Address
        Do
            i = i + 1
            wks.Rows(c.Row).Copy Worksheets("Tabelle2").Cells(i, 1)
            Set c = .FindNext(c)
        Loop While c.Address <> firstaddress
    End If
End With
Application.ScreenUpdating = True
End Sub

 

Hallo bindoof,

Willst Du wirklich Zeilen in Spalten kopieren, oder ist das ein Tippfehler?

Und generell ist es immer am besten eine Beispieldatei hier im Forum hochzuladen, die den gleichen Aufbau wie die Originaldatei hat, und auch Deinen Code enthält.
Die Daten können ja gerne Dummys sein, und so ca. 20 Datensätze sollten auch genügen.

 

Ahh Mist, nein, ich will natürlich Zeilen in Zeilen kopieren

Ich habe mal kurz die exemplarische Testdatei angehangen...

 

Hallo bindoof,

quick and dirty:

Code:

Option Explicit

Public Sub kopieren()

Dim lRow As Long, lCol As Long, i As Long
Dim firstaddress As String
Dim c As Range
Dim wks1 As Worksheet, wks2 As Worksheet

    Application.ScreenUpdating = False
    
    Set wks1 = ThisWorkbook.Worksheets("Tabelle1")
    Set wks2 = ThisWorkbook.Worksheets("Tabelle2")
    
    wks2.Visible = True   'einblenden
    
    ' die ersten beiden Zeilen kopieren
    wks1.Rows("1:2").Copy wks2.Cells(1, 1)
        
    With wks1.Range("a1:G" & wks1.Cells(Rows.Count, 2).End(xlUp).Row)
        i = 3   ' erste Datenzeile
        Set c = .Find(what:="8.8", LookIn:=xlValues, lookat:=xlPart)
        If Not c Is Nothing Then
            firstaddress = c.Address
            Do
                wks1.Rows(c.Row).Copy wks2.Cells(i, 1)
                i = i + 1
                Set c = .FindNext(c)
            Loop While c.Address <> firstaddress
        End If
    End With
    
    ' letzte benutzte Spalte ermitteln
    lCol = wks1.Cells(1, Columns.Count).End(xlToLeft).Column
    ' Spaltenbreite einstellen
    For i = 1 To lCol
        wks2.Columns(i).ColumnWidth = wks1.Columns(i).ColumnWidth
    Next i
    
    Application.ScreenUpdating = True

End Sub

Sag mal, warum setzt Du Tabelle2 auf "visible = true" ???
Ist das Blatt vorher ausgeblendet?
Oder möchtest Du dieses Blatt aktivieren, also den Reiter auswählen?
Dann müstest Du "wks2.Activate" verwenden.

Kopiere meinen kompletten Code, es könnten Dir sonst Kleinigkeiten entgehen die ich geändert habe.
;O)

 

Vielen vielen Dank, genau so wollte ich es haben :D

..weder noch, ich hab mir den Code nur nach diverser Recherche zusammenkopiert.
Den Befehl kann ich dann eigentlich entfernen, da er keinen Nutzen hat.

Ich hätte da aber nochmal eine andere Frage....

Die entsprechenden Zeilen wurden jetzt mit Hilfe des Codes in Tabelle2 kopiert.
Ich würde jetzt gerne in Spalte A von Tabelle2 jeweils eine Schaltfläche pro Zeile (angefangen ab A3 haben), die mir dann wiederum, die entprechende Zeile (oder falls möglich, zB. von B3 bis Bx, von B4 bis Bx, von B5 bis Bx etc.) in eine weitere Tabelle3, in z.B. Feld A1 kopiert.
Die Schaltflächen sollen fest in Tabelle 2 ab A3 bis Ax durchlaufend vorhanden sein, also schon bevor die Stringzeilen von Tabelle1 nach Tabelle2 kopiert wurden.
Dazu müsste man den alten Code zuvor so noch so ändern , das alles aus TabelleA erst ab Spalte B der Tabelle2 eingefügt wird.

Ich hoffe ich habe mich jetzt nicht zu kompliziert ausgedrückt :p

 

Könnte man so machen (habe wieder ein paar Änderungen, also bitte komplett kopieren und den alten ersetzen):

Code:

Option Explicit

Public Sub CopyTab1toTab2()

Dim lRow As Long, lCol As Long, i As Long
Dim firstaddress As String
Dim c As Range
Dim wks1 As Worksheet, wks2 As Worksheet

    Application.ScreenUpdating = False
    
    Set wks1 = ThisWorkbook.Worksheets("Tabelle1")
    Set wks2 = ThisWorkbook.Worksheets("Tabelle2")
    
    With wks1
        ' letzte benutzte Spalte in Tabelle1 ermitteln
        lCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
        
        ' die zweite Zeile kopieren
        .Range(.Cells(2, 1), .Cells(2, lCol)).Copy wks2.Cells(2, 2)
            
        With .Range("A1:" & .Cells(.UsedRange.SpecialCells(xlCellTypeLastCell).Row, 1).Address)
            i = 3   ' erste Datenzeile
            Set c = .Find(what:="8.8", LookIn:=xlValues, lookat:=xlPart)
            If Not c Is Nothing Then
                firstaddress = c.Address
                Do
                    .Range(.Cells(c.Row, 1), .Cells(c.Row, lCol)).Copy wks2.Cells(i, 2)
                    i = i + 1
                    Set c = .FindNext(c)
                Loop While c.Address <> firstaddress
            End If
        End With
    End With
    
    ' Spaltenbreite einstellen
    For i = 1 To lCol
        wks2.Columns(i).ColumnWidth = wks1.Columns(i).ColumnWidth
    Next i
    
    Application.ScreenUpdating = True

End Sub

Die Schaltflächen würde ich mir sparen, sondern einfach die Zellen in Spalte A beschriften und das "SelectionChange Ereignis" benutzen. Sprich immer wenn Du eine Zelle in Spalte A anklickst, wird das Makro ausgelöst.
Dazu muss der folgende Code in das Modul von Tabelle2:

Code:

Option Explicit

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

Dim lCol As Long
Dim wks3 As Worksheet

Set wks3 = ThisWorkbook.Worksheets("Tabelle3")

    ' Bedingungen: wenn nur eine Zelle ausgewählt wird, die sich in Spalte A, und unterhalb der zweiten Zeile befindet
    If Target.Count = 1 And Target.Column = 1 And Target.Row > 2 Then
        With Me
            ' letzte benutzte Spalte der Zeile in Tabelle2 ermitteln
            lCol = .Cells(Target.Row, .Columns.Count).End(xlToLeft).Column
            .Range("B" & Target.Row & ":" & .Cells(Target.Row, lCol).Address).Copy wks3.Cells(1, 1)
        End With
    End If

End Sub

 

Nochmals vielen Dank für die Anpassung :D

Das "SelectionChange Ereignis" funktioniert gut so.

Nur noch eine Kleinigkeit... jetzt wird nur noch die zweite Überschriftenzeile aus Tabelle1 in Tabelle2 kopiert und in Tabelle2 bleibt die Zeile 1 leer, es sollen aber beide Überschriftenzeilen kopiert werden. Vielleicht habe ich das vorher falsch dargestellt...

 

Hallo bindoof,

ich glaub das war mein Fehler. Habs wohl falsch verstanden.
Ersetze:

Code:

' die zweite Zeile kopieren
.Range(.Cells(2, 1), .Cells(2, lCol)).Copy wks2.Cells(2, 2)

durch

Code:

' die ersten beiden Zeilen kopieren
.Range(.Cells(1, 1), .Cells(2, lCol)).Copy wks2.Cells(1, 2)

(ungetestet)

 

Danke fette Elfe,

jetzt ist alles so, wie ich es haben wollte. :D

Du hast mir da wirklich super geholfen, nochmals vielen Dank für die Hilfe !