Makro soll andere Zellen kopieren

Bild

Betrifft: Makro soll andere Zellen kopieren
von: Jenny
Geschrieben am: 22.08.2015 12:11:58

Hallo an alle,
bitte helft mir. Es geht um unten stehendes Makro,
genau genommen um den Teil

Sheets("Tabelle1").Activate
       Application.ScreenUpdating = True
       With Cells(Rows.Count, 8).End(xlUp)
        .Resize(1, 6).Copy
        .Activate
       End With
und zwar in sofern, dass nicht mehr die insgesamt letzte Zeile mit Inhalt in Spalte H genommen wird, sondern die erste leere Zelle in Spalte H gesucht werden soll und dann die Zeile obendrüber kopiert werden soll, auch wenn es später noch Zeilen mit Inhalt in Spalte H gibt.
Wenn H1 leer ist, soll die erste Zeile mit Inhalt kopiert werden, egal ob dies Zeile 2, 3 oder 20 ist.
Kann mir da jemand helfen?
Vielen Dank
Jenny
Sub Makro3()
'
' Makro3 Makro
'
' Tastenkombination: Strg+i
'
        Dim zt1&, von&, bis As Long
       Dim Grafiken As Shape
       Dim c As Range, a As Variant
       Application.ScreenUpdating = False
       With Sheets("Tabelle1")
           zt1 = .Cells(.Rows.Count, 1).End(xlUp).Row
           von = 1
           With Sheets("Tabelle2")
               bis = .Cells(.Rows.Count, 2).End(xlUp).Row
               .Range(.Cells(von, 2), .Cells(bis, 2)).Copy Sheets("Tabelle1").Cells(zt1, 6)
           End With
           With Sheets("Tabelle3")
               .Range(.Cells(von, 5), .Cells(bis, 5)).Copy
           End With
           .Cells(zt1, 7).PasteSpecial Paste:=xlPasteValues
           Application.CutCopyMode = False
          If bis > 1 Then
               .Range(.Cells(zt1, 1), .Cells(zt1, 3)).Copy _
                Destination:=.Range(.Cells(zt1 + 1, 1), .Cells(zt1 + bis - von, 1))
          End If
           Application.CutCopyMode = False
           
     Sheets("Tabelle1").Range("D" & zt1 - 1 & ":E" & zt1 - 1).Copy _
    Sheets("Tabelle1").Range("D" & zt1 & ":E" & zt1 + bis - von)
 
           For Each c In Range(.Cells(zt1, 6), .Cells(zt1 + bis - von + 1, 6))
             If c.Hyperlinks.Count > 0 Then
                a = Split(c.Hyperlinks(1).Address, "/")
                c.Offset(0, -1).Value = a(UBound(a) - 1)
             End If
           Next
          .Range(.Cells(1, 1), .Cells(zt1 + 1 + bis - von, 14)).Sort _
           key1:=.Range("D1"), Order1:=xlAscending, _
          key2:=.Range("G1"), Order2:=xlDescending, Header:=xlNo
       End With
       With Sheets("Tabelle2")
           .Range(.Cells(1, 1), .Cells(bis, 3)).Clear
       End With
       With Sheets("Tabelle3")
        .Range(.Cells(1, 1), .Cells(bis, 4)).Clear
         For Each Grafiken In .Shapes
               Grafiken.Delete
         Next
       End With
       Sheets("Tabelle1").Activate
       Application.ScreenUpdating = True
       With Cells(Rows.Count, 8).End(xlUp)
        .Resize(1, 6).Copy
        .Activate
       End With
   End Sub

Bild

Betrifft: AW: Makro soll andere Zellen kopieren
von: AlexG
Geschrieben am: 22.08.2015 16:53:42
Hallo Jenny,
so?

Dim i As Integer
Sheets("Tabelle1").Activate
Application.ScreenUpdating = True
    If Application.CountA(Columns(8)) > 0 Then
       If IsEmpty(Cells(1, 8)) Then
          With Cells(1, 8).End(xlDown)
            .Resize(1, 6).Copy
            .Activate
          End With
       Else
          For i = 1 To Cells(Rows.Count, 8).End(xlUp).Offset(1).Row
            If IsEmpty(Cells(i, 8)) Then
                With Cells(i, 8).Offset(-1, 0)
                    .Resize(1, 6).Copy
                    .Activate
                End With
                Exit Sub
            End If
            Next i
       End If
    End If

Gruß
Alex

Bild

Betrifft: AW: Makro soll andere Zellen kopieren
von: Jenny
Geschrieben am: 22.08.2015 18:10:44
Hallo Alex,
ich bekomme einen Laufzeitfehler, vermute allerdings es liegt daran, dass ich nicht gan schlüssig bin, wo an welcher Stelle ich deinen Teil einfügen soll.
Kannst du mir bitte das komplette Makro einmal hier hinschreiben?
Danke
Jenny

Bild

Betrifft: Komplett
von: AlexG
Geschrieben am: 22.08.2015 18:21:47
Hallo Jenny,
hier der gesamte Code.

Sub Makro3()
  ' 
  ' Makro3 Makro 
  ' 
  ' Tastenkombination: Strg+i 
  ' 
         Dim i, zt1&, von&, bis As Long
         Dim Grafiken As Shape
         Dim c As Range, a As Variant
         Application.ScreenUpdating = False
         With Sheets("Tabelle1")
             zt1 = .Cells(.Rows.Count, 1).End(xlUp).Row
             von = 1
             With Sheets("Tabelle2")
                 bis = .Cells(.Rows.Count, 2).End(xlUp).Row
                 .Range(.Cells(von, 2), .Cells(bis, 2)).Copy Sheets("Tabelle1").Cells(zt1, 6)
             End With
             With Sheets("Tabelle3")
                 .Range(.Cells(von, 5), .Cells(bis, 5)).Copy
             End With
             .Cells(zt1, 7).PasteSpecial Paste:=xlPasteValues
             Application.CutCopyMode = False
            If bis > 1 Then
                 .Range(.Cells(zt1, 1), .Cells(zt1, 3)).Copy _
                  Destination:=.Range(.Cells(zt1 + 1, 1), .Cells(zt1 + bis - von, 1))
            End If
             Application.CutCopyMode = False
             
       Sheets("Tabelle1").Range("D" & zt1 - 1 & ":E" & zt1 - 1).Copy _
      Sheets("Tabelle1").Range("D" & zt1 & ":E" & zt1 + bis - von)
   
             For Each c In Range(.Cells(zt1, 6), .Cells(zt1 + bis - von + 1, 6))
               If c.Hyperlinks.Count > 0 Then
                  a = Split(c.Hyperlinks(1).Address, "/")
                  c.Offset(0, -1).Value = a(Ubound(a) - 1)
               End If
             Next
            .Range(.Cells(1, 1), .Cells(zt1 + 1 + bis - von, 14)).Sort _
             key1:=.Range("D1"), Order1:=xlAscending, _
            key2:=.Range("G1"), Order2:=xlDescending, Header:=xlNo
         End With
         With Sheets("Tabelle2")
             .Range(.Cells(1, 1), .Cells(bis, 3)).Clear
         End With
         With Sheets("Tabelle3")
          .Range(.Cells(1, 1), .Cells(bis, 4)).Clear
           For Each Grafiken In .Shapes
                 Grafiken.Delete
           Next
         End With
    Sheets("Tabelle1").Activate
    Application.ScreenUpdating = True
    If Application.CountA(Columns(8)) > 0 Then
       If IsEmpty(Cells(1, 8)) Then
          With Cells(1, 8).End(xlDown)
            .Resize(1, 6).Copy
            .Activate
          End With
       Else
          For i = 1 To Cells(Rows.Count, 8).End(xlUp).Offset(1).Row
            If IsEmpty(Cells(i, 8)) Then
                With Cells(i, 8).Offset(-1, 0)
                    .Resize(1, 6).Copy
                    .Activate
                End With
                Exit Sub
            End If
            Next i
       End If
    End If
End Sub

Gruß
Alex

Bild

Betrifft: AW: Komplett
von: Jenny
Geschrieben am: 22.08.2015 18:50:34
Hallo Alex,
dann hatte ich es doch richtig gemacht,
das Problem lag an

       Sheets("Tabelle1").Range("D" & zt1 - 1 & ":E" & zt1 - 1).Copy _
      Sheets("Tabelle1").Range("D" & zt1 & ":E" & zt1 + bis - von)
das hatte nicht funktioniert da beim Starten die Tabelle1 noch leer war, aber jetzt beim ersten Ausführen die beiden Zeilen ausgeblendet und von Hand die Sachen kopiert
und jetzt beim 2. Ausführen klappts auch mit den beiden Zeilen
DAnke und LG
Jenny

Bild

Betrifft: AW: Komplett
von: AlexG
Geschrieben am: 22.08.2015 18:52:57
Hallo Jenny,
das freut mich das es jetzt klappt.
Schöne Grüße
Alex

 Bild

Beiträge aus den Excel-Beispielen zum Thema "Makro soll andere Zellen kopieren"