AW: VBA - Kopieren von Tabellenblatt 1 zu BLatt 2
09.02.2016 22:45:35
Tabellenblatt
Hallo erst mal ...
anbei 3 Makros als Lösung für diese Aufgabe. Warum drei ..?
Ich mache nicht gerne halbe Sachen, denke lieber Praxisgerecht!
Das 1. Makro ist die Grundlösung zum kopieren, sie ist aber nicht Praxisgerecht!
Als grundlegende Funktion taucht es in den beiden anderen Makros wieder auf.
Der Kopiervorgang in Makro1 laeuft als Demo über Range(SuchBer) "L6:L9". Dieser Bereich verschiebt
sich ja in der Praxis staendig nach unten. Es ist unsinnig den Bereich jedesmal von Hand festzulegen.
Die Kopier Funktion ist okay, aber für die taegliche Praxis so nicht brauchbar.
Bedingung: keine doppelten ID Nummern
Makro 2 ist m.E. die beste Lösung, setzt aber voraus das die ID Nummern nicht doppelt sind!
Hier suche ich zuerst in Blatt2 ab wo die aktuelle ID Nummer fehlt. Das ist die Start-Adresse
Alternativ: Spalte P als Hilfsspalte
Makro 3 benutzt P als Hilfsspalte und erwartet ein Zeichen ab wo der Start beginnen soll.
Für die End-Adresse benutze ich den letzten Eintrag in Spalte C.
Somit gibt es zwei Möglichkeiten für die Praktische Anwendung.
Würde mich freuen wenn das Programm zufriedenstellend laeuft.
PS ich weiss nicht ob es erforderlich ist noch eine Prüfung zu machen das keine Werte doppelt
übertragen werden. War hier nicht gefordert.
mfg Piet
Option Explicit '9.2.2016 Piet für Herber Forum
Const SuchBer = "L6:L9"
Dim Adr As String, Spa
Dim Edr As String, Zei
'Copy Grundmodul über Range(SuchBer)
Sub Blatt1_nach_Blatt2_kopieren()
'1. Schleife für suche in Spalte L
For Each Spa In Sheets("Blatt 1").Range(SuchBer)
'2. Schleife für Zelle 1-4 (rechts)
For Zei = 1 To 4
If Spa.Cells(1, Zei) = 1 Then
'Wenn L=1 ist ID Nummer vorhanden?
If Cells(Spa.Row, "C") Empty Then
'Copy Anf- und End Adresse festlegen
Adr = Cells(Spa.Row, "A").Address
Edr = Cells(Spa.Row, "O").Address
'In Blatt2 eine Zeile einfügen und nach unten schieben
Sheets("Blatt 2").Rows("1:1").Insert Shift:=xlDown
'Blatt1: Spalte A-O kopieren, nur Werte einfügen
Sheets("Blatt 1").Range(Adr, Edr).Copy
Sheets("Blatt 2").Range("A1").PasteSpecial xlValues
Application.CutCopyMode = False 'CopyMode Aus
End If
End If
Next Zei
Next Spa
End Sub
Option Explicit '9.2.2016 Piet für Herber Forum
Dim SAdr As String, SEdr As String
Dim Adr As String, Spa, z
Dim Edr As String, Zei, ID
'Bedingung: -keine doppelte IDs- !!
'sucht in Blatt2 nach ID Nummer bis
'die 1. -fehlende ID- gefunden wird
Sub Blatt1_kopieren_überID_Suchlauf()
Dim rFind As Object, B2 As Object
Set B2 = Sheets("Blatt 2")
z = Cells.Rows.Count 'End Zelle "C"
'SEdr zuerst für Spalte C festlegen
SEdr = Range("C" & z).End(xlUp).Address
'Suchschleife für alle vorhandenen IDs in Blatt 2
'Ende wenn ID in Blatt2 -nicht gefunden wird-
For Each ID In Sheets("Blatt 1").Range("C1", SEdr)
Set rFind = Sheets("Blatt 2").Columns(3) _
.Find(What:=ID, After:=B2.[c1], LookIn:=xlFormulas, LookAt:=xlWhole)
If rFind Is Nothing Then Exit For
Next ID
'SAdr + SEdr für Spalte L festlegen
SAdr = Range(ID.Address).Cells(1, 10).Address
SEdr = Range(SEdr).Cells(1, 10).Address
'1. Schleife für suche in Spalte L
For Each Spa In Sheets("Blatt 1").Range(SAdr, SEdr)
'2. Schleife für Zelle 1-4 (rechts)
For Zei = 1 To 4
If Spa.Cells(1, Zei) = 1 Then
'Wenn L=1 ist ID Nummer vorhanden?
If Cells(Spa.Row, "C") Empty Then
'Copy Anf- und End Adresse festlegen
Adr = Cells(Spa.Row, "A").Address
Edr = Cells(Spa.Row, "O").Address
'In Blatt2 eine Zeile einfügen und nach unten schieben
Sheets("Blatt 2").Rows("1:1").Insert Shift:=xlDown
'Blatt1: Spalte A-O kopieren, nur Werte einfügen
Sheets("Blatt 1").Range(Adr, Edr).Copy
Sheets("Blatt 2").Range("A1").PasteSpecial xlValues
Application.CutCopyMode = False 'CopyMode Aus
End If
End If
Next Zei
Next Spa
End Sub
Option Explicit '9.2.2016 Piet für Herber Forum
Dim SAdr As String, SEdr As String
Dim Adr As String, Spa, z
Dim Edr As String, Zei
'Hilfsspalte P 1.Wert für Programm Start
'Spalte C letzte Zelle für Programm Ende
'Start Zeichen wird am Ende gelöscht!!
Sub Blatt1_kopieren_Hilfsspalte_P()
'sucht in Spalte P 1.Wert und in C letzten Wert
z = Cells.Rows.Count 'End Zelle oder Zahl angeben
SAdr = Range("P1").End(xlDown).Cells(1, -3).Address
SEdr = Range("C" & z).End(xlUp).Cells(1, 10).Address
'1. Schleife für suche in Spalte L
For Each Spa In Sheets("Blatt 1").Range(SAdr, SEdr)
'2. Schleife für Zelle 1-4 (rechts)
For Zei = 1 To 4
If Spa.Cells(1, Zei) = 1 Then
'Wenn L=1 ist ID Nummer vorhanden?
If Cells(Spa.Row, "C") Empty Then
'Copy Anf- und End Adresse festlegen
Adr = Cells(Spa.Row, "A").Address
Edr = Cells(Spa.Row, "O").Address
'In Blatt2 eine Zeile einfügen und nach unten schieben
Sheets("Blatt 2").Rows("1:1").Insert Shift:=xlDown
'Blatt1: Spalte A-O kopieren, nur Werte einfügen
Sheets("Blatt 1").Range(Adr, Edr).Copy
Sheets("Blatt 2").Range("A1").PasteSpecial xlValues
Application.CutCopyMode = False 'CopyMode Aus
End If
End If
Next Zei
Next Spa
'Spalte P Start Zeichen löschen
Range(SAdr).Cells(1, 5) = Empty
End Sub