Excel vba zelle in eine bestimmte zelle kopieren

Computer: Software & Programmierung Visual Basic
#1

Hallo liebes Forum,

meine ersten Schritte in VBA bestehen darin über Google Lösungen zu finden und diese auf meine Bedürfnisse anzupassen.

Aktuell habe ich den Großteil schon gelöst (nicht elegant aber zielführend), aber am Schluss hackt es an einer Kleinigkeit.

Im folgenden seht ihr mein VBA Code: Ich möchte das die kopierten Werte aus dem Tabellenblatt „Quelle“ in das Zieltabellenblatt „Gerhard“ erst ab der zweiten Zeile kopiert werde, damit ich die Kopfzeile behalten kann.

Irgendwelche Vorschläge?

Danke für euere Bemühung!

Sub Gerhard()
Dim c, firstaddress, wks1 As Worksheet, wks2 As Worksheet, Zei As Long
Sheets(„Gerhard“).Cells.Clear
Set wks1 = Worksheets(„Quelle“)
Set wks2 = Worksheets(„Gerhard“)
With wks1.UsedRange
Set c = .Find(„Gerhard“, LookIn:=xlValues)
If Not c Is Nothing Then
firstaddress = c.Address
Do
Zei = Zei + 1
c.EntireRow.Copy Destination:=wks2.Cells(Zei, 1)
Set c = .FindNext©
Loop While Not c Is Nothing And c.Address firstaddress
Worksheets(„Quelle“).Activate
Worksheets(„Quelle“).Rows(„1:1“).Select
Selection.Copy
Worksheets(„Gerhard“).Select
Worksheets(„Gerhard“).Rows(„1:1“).Select
ActiveSheet.Paste
End If
End With
End Sub

#2

Hallo,

Probiers mit den Code

Sub Gerhard()
Dim c, firstaddress, wks1 As Worksheet, wks2 As Worksheet, Zei As Long
Sheets(„Gerhard“).Cells.Clear
Set wks1 = Worksheets(„Quelle“)
Set wks2 = Worksheets(„Gerhard“)
With wks1.UsedRange
Set c = .Find(„Gerhard“, LookIn:=xlValues)
If Not c Is Nothing Then
firstaddress = c.Address
Do While Not c Is Nothing And c.Address firstaddress
Zei = Zei + 1
c.EntireRow.Copy Destination:=wks2.Cells(Zei, 1)
Set c = .FindNext©
Loop
Worksheets(„Quelle“).Activate
Worksheets(„Quelle“).Rows(„1:1“).Select
Selection.Copy
Worksheets(„Gerhard“).Select
Worksheets(„Gerhard“).Rows(„1:1“).Select
ActiveSheet.Paste
End If
End With
End Sub

Fehler liegt in der do while schleife.

Lg Fred

#3

Hallo Neuling111,

bei den Variablen sollte man ggf. Namen verwenden, die etwas aussagekräftiger sind. Auch sollte man die Variablen mit As als den Typ deklarieren, den sie repräsentieren sollen. So wird das Programmieren etwas einfacher.

Um das Einfügen nicht in Zeile 1 zu beginnen, muss du vor der Do…Loop-Schleife auf den Wert setzen, nach dem mit dm Einfügen begonnen werden soll.

Auf Activate und Select/Selection kann man in den meisten Fällen ebenfalls verzichten und die betroffenen Objekte direkt angeben. Activate und Select/Selection sind meist Überreste eines vom Makro-Recorder aufgezeichneten Codes, die man entsprechend einkürzen kann.

Gruß
Franz

Sub Gerhard()
 Dim oZelle As Range, firstaddress As String
 Dim wksQuelle As Worksheet, wksZiel As Worksheet, Zei As Long

 Set wksQuelle = Worksheets("Quelle")
 Set wksZiel = Worksheets("Gerhard")

 'Alle Daten iin Zieltabelle ab Zeile 2 löschen
 With wksZiel
 Zei = .Cells.SpecialCells(xlCellTypeLastCell).Row
 If Zei \> 1 Then
 .Range(.Rows(2), Rows(Zei)).Clear
 End If
 Zei = 1 'Zeile 1 bleibt frei für Überschrift
 End With

 With wksQuelle.UsedRange
 Set oZelle = .Find("Gerhard", LookIn:=xlValues)
 If Not oZelle Is Nothing Then
 firstaddress = oZelle.Address
 Do
 Zei = Zei + 1
 oZelle.EntireRow.Copy Destination:=wksZiel.Cells(Zei, 1)
 Set oZelle = .FindNext(oZelle)
 Loop While Not oZelle Is Nothing And oZelle.Address firstaddress

 'Titelzeile kopieren - die nachfolgende Zeile ist ggf. nicht mehr erforderlich
 wksQuelle.Rows("1:1").Copy Destination:=wksZiel.Rows("1:1")
 End If
 End With
End Sub
#4

Hallo Neuling111,

so wie ich das sehe, musst du nur vor der Zeile Zei = Zei + 1 die Zeile Zei = 1 einfügen, denn dann fängt Zei nicht bei 0, sondern 1 an und wird ja direkt um 1 auf 2 erhöht.

Gruß
Natator

#5

Hallo Neuling,

einfach Worksheets(„Gerhard“).Rows(„1:1“).Select
durch Worksheets(„Gerhard“).Rows(„2:2“).Select
ersetzen.

Kleiner Tipp:
Schau Dir mal die Website www.herber.de an, dann brauchst Du nicht mehr zu ggooglen - hier findest Du (fast) alle antworten zu Excelfragen.

Gruß,
Ptonka

#6

Hallo Neuling1111,

Sub Gerhard()
 Dim c, firstaddress, wks1 As Worksheet, wks2 As Worksheet, Zei As Long
 Set wks1 = Worksheets("Quelle")
 Set wks2 = Worksheets("Gerhard")
**wks2.Cells.Clear**
 With wks1.UsedRange
 Set c = .Find("Gerhard", LookIn:=xlValues)
 If Not c Is Nothing Then
 firstaddress = c.Address
**Zei = 2  
 Do  
 c.EntireRow.Copy Destination:=wks2.Cells(Zei, 1)  
 Zei = Zei + 1  
 Set c = .FindNext(c)  
 Loop While Not c Is Nothing And c.Address firstaddress  
 wks1.Rows("1:1").Copy Destination:=wks2.Rows("1:1")**  
 End If
 End With
End Sub

MfG
W.W.

#7

Grüezi Neuling

meine ersten Schritte in VBA bestehen darin über Google
Lösungen zu finden und diese auf meine Bedürfnisse anzupassen.

Das sieht ja schon recht gut aus :smile:

Im folgenden seht ihr mein VBA Code: Ich möchte das die
kopierten Werte aus dem Tabellenblatt „Quelle“ in das
Zieltabellenblatt „Gerhard“ erst ab der zweiten Zeile kopiert
werde, damit ich die Kopfzeile behalten kann.

Irgendwelche Vorschläge?

Versuche es mal mit den folgenden Zeilen:

Option Explicit

Sub Gerhard()
Dim wks1 As Worksheet
Dim wks2 As Worksheet
Dim c As Range
Dim firstaddress As String
Dim Zei As Long

 Set wks1 = Worksheets("Quelle")
 Set wks2 = Worksheets("Gerhard")

 wks2 .Cells.Clear

 With wks1.UsedRange
 Set c = .Find("Gerhard", LookIn:=xlValues)
 If Not c Is Nothing Then
 firstaddress = c.Address
 Zei = 1
 Do
 Zei = Zei + 1
 c.EntireRow.Copy Destination:=wks2.Cells(Zei, 1)
 Set c = .FindNext(c)
 Loop While Not c Is Nothing And c.Address firstaddress
 wks1.Rows(1).Copy \_
 wks2.Rows(1)
 End If
 End With
End Sub

Mit freundlichen Grüssen

Thomas Ramel

  • MVP für MS-Excel -
#8

Hallo,
versuchs mal damit. Das Beispiel ist ausgelegt für 20 Spalten und unbegrenzte Zeilen!

Sub Kopieren()
Sheets(„Gerhard“).Activate
Dim aRow As Long, Datum As Date
aRow = Cells(Cells.Rows.Count, 1).End(xlUp).Row
Range(Cells(2, 1), Cells(aRow, 20)).Select
Selection.ClearContents
Cells(2, 1).Select
Sheets(„Quelle“).Activate
aRow = Cells(Cells.Rows.Count, 1).End(xlUp).Row
Range(Cells(2, 1), Cells(aRow, 20)).Select
Selection.Copy
Sheets(„Gerhard“).Activate
ActiveSheet.Paste
End Sub

mfg
Softoldi

#9

Hallo Neuling1111
in der 3.Zeile vom Modul „Kopieren“ kannst du folgendes löschen. „Datum As Date“
Ist mir so reingerutscht:.)

mfg
Softoldi

#10

Hallo Fred, vielen herzliche Dank für deine Unterstützung!

#11

Hallo Franz, vielen herzlichen Dank für deine Unterstützung!

#12

Hallo Natator, vielen herzliche Dank für deine Unterstützung!

#13

Hallo Ptonka, vielen herzlich Dank für deine Unterstützung!

#14

Hallo Waldemar, vielen herzlichen Dank für deine Unterstützung!

#15

Hallo Thomas, vielen herzlich Dank für deine Unterstützung!

#16

Hallo Softoldi, vielen herzlichen Dank für deine Unterstützung!

#17

hallo neuling, es sind ja schon viele vorschläge da. - alternativ könnte man, wenn „gerhard“ nur in einer spalte vorkommt, die gesamte quelltabelle auf die zieltabelle kopieren, dort nach der betreffenden spalte sortieren und alles unter- und oberhalb von „gerhard“ außer der 1.zeile löschen. solche lösungen bevorzuge ich gerade bei großen datenmengen, da ich do-loop-schleifen für langsam halte und gerne darauf verzichte . wenn gewünscht, schreibe ich das programm an dieser stelle. herzliche grüße und viel erfolg, ascan

#18

Hallo,

versuch es mal so:

sub Gerhard()

sheets(„Quelle“).select
cells(2,1).select

Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Copy

sheets(„Gerhard“).select
cells(2,1).select
ActiveSheet.Paste

Und: Klappt das?

#19

Hallo Neuling1111,

leider fehlt in meinem letzten Script an dich noch eine Zeile. Anbei das bereinigte Script!

’ Kopiert die Daten von Tabelle zu
’ von Zeile-2 bis letzte Zeile
’ von Spalte-1 bis Spalte-20
Sub Kopieren()
Sheets(„Gerhard“).Activate
Dim aRow As Long
aRow = Cells(Cells.Rows.Count, 1).End(xlUp).Row
If aRow = 1 Then aRow = 2
Range(Cells(2, 1), Cells(aRow, 20)).Select
Selection.ClearContents
Cells(2, 1).Select
Sheets(„Quelle“).Activate
aRow = Cells(Cells.Rows.Count, 1).End(xlUp).Row
Range(Cells(2, 1), Cells(aRow, 20)).Select
Selection.Copy
Sheets(„Gerhard“).Activate
ActiveSheet.Paste
End Sub

mfg
Softoldi

#20

kann leider erst jetzt antworten da ich im Urlaub war.
Ich vermute da sind viele schon schneller gewesen und
haben sich tolle Lösungen gegeben, daher keine von mir.

Gruß Hugo