Live-Forum - Die aktuellen Beiträge
Anzeige
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Zellen in anderes Arbeitsblatt kopieren
Stefan
Hallo,
Ich habe eine Quell- und eine Zieldatei in jeweils verschiedenen Arbeitsmappen. Beide Dateien haben die gleiche Struktur.
dazu habe ich folgenden Code, der mir hier zur Verfügung gestellt wurde:
Private Sub CommandButton1_Click()
Dim wksQuelle As Worksheet
Dim rngRow As Range, rngSelektion As Range
Dim wbSammler As Workbook, wksSammler As Worksheet, rngZelle As Range
Dim vKey As Variant, lZeile As Long
'Spalte mit eindeutgem Schlüssel = Spalte B
Const SpalteKey As Long = 2
'Dateiname der Sammeldatei                                    -  anpassen !
Const sNameSammler As String = "\\\\Malibu\Projekte\SAP\300_Test\2011\110_Verwaltung\ _
20_Auswertungen\Workflow_GSZ_2011.xlsm"
'Blattname oder Nr des Tabellenblatts in Sammeldatei      - ggf. anpassen !
Const vBlattSammler = 1
On Error GoTo Fehler
'Quellblatt und Zell-Selektion Objekt-Variablen zuweisen
Set wksQuelle = ActiveSheet
Set rngSelektion = Selection
'1. Zeile des selektierten Bereichs prüfen
If rngSelektion.Row  Sammeldatei") = vbNo Then GoTo Beenden
'Bildschirmaktualisierung und Ereignismakros deaktivieren
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
'Sammeldatei öffnen
Set wbSammler = Workbooks.Open(Filename:=sNameSammler, Ignorereadonlyrecommended:=True)
Set wksSammler = wbSammler.Worksheets(vBlattSammler)
'Keys der Selektion in Sammeldatei suchen und Zeilen kopieren
For Each rngRow In rngSelektion.Rows
vKey = wksQuelle.Cells(rngRow.Row, SpalteKey).Value
Set rngZelle = wksSammler.Columns(SpalteKey).Find(What:=vKey, LookIn:=xlValues, _
lookat:=xlWhole)
With wksSammler
If rngZelle Is Nothing Then
'Neuer Schlüssel
lZeile = .Cells(.Rows.Count, SpalteKey).End(xlUp).Row + 1
Else
'vorhandener Schlüssel
lZeile = rngZelle.Row
End If
End With
wksQuelle.Rows(rngRow.Row).Copy Destination:=wksSammler.Rows(lZeile)
Next
wbSammler.Close savechanges:=True
Beenden:
Fehler:
With Err
Select Case .Number
Case 0 'alles ok
Case Else
MsgBox "Fehler-Nr.: " & .Number & vbLf & .Description
End Select
End With
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub

Der Code leistet folgendes:
Anwender/in gibt in eine Zeile der Quelldatei Daten ein, markiert die Zeile, klickt auf einen Button, im Hintergrund öffnet sich die Zieldatei, die eingegebenen Daten werden in die Zieldatei kopiert, Zieldatei wird geschlossen (dabei sind die Daten in Spalte B einmalig, d. h. der Code vergleicht den Eintrag von Quelldatei Spalte B mit Eintrag Zieldatei Spalte B, ist der Eintrag schon vorhanden wird in Zieldatei die entsprechende Zeile überschrieben, falls noch nicht vorhanden am Ende angefügt).
Mein Problem:
Ist es möglich, daß der Anwender statt die ganze Zeile zu markieren und dann eben diese Zeile in Zieldatei
kopiert wird einzelne Zellen markiert und diese dann kopiert in die Zieldatei?
Viele Grüße
Stefan

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

Betreff
Benutzer
Anzeige
AW: Zellen in anderes Arbeitsblatt kopieren
03.03.2011 20:04:40
fcs
Hallo Stefan,
mit den folgenden Anpassungen werden die selektierten Zeilen oder Zellen in den Sammler kopiert.
Sollte ein Schlüssel im Sammler nicht vorhanden sein, dann wird ggf. der Schlüssel zusätzlich zu den selektierten Zellen kopiert.
Gruß
Franz
Private Sub CommandButton1_Click()
Dim wksQuelle As Worksheet
Dim rngRow As Range, rngSelektion As Range
Dim wbSammler As Workbook, wksSammler As Worksheet, rngZelle As Range
Dim vKey As Variant, lZeile As Long
'Spalte mit eindeutgem Schlüssel = Spalte B
Const SpalteKey As Long = 2
'Dateiname der Sammeldatei                                    -  anpassen !
Const sNameSammler As String = "\\\\Malibu\Projekte\SAP\300_Test\2011\" _
& "110_Verwaltung\20_Auswertungen\Workflow_GSZ_2011.xlsm"
'Blattname oder Nr des Tabellenblatts in Sammeldatei      - ggf. anpassen !
Const vBlattSammler = 1
On Error GoTo Fehler
'Quellblatt und Zell-Selektion Objekt-Variablen zuweisen
Set wksQuelle = ActiveSheet
Set rngSelektion = Selection
'1. Zeile des selektierten Bereichs prüfen
If rngSelektion.Row  Sammeldatei") = vbNo Then GoTo Beenden
'Bildschirmaktualisierung und Ereignismakros deaktivieren
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
'Sammeldatei öffnen
Set wbSammler = Workbooks.Open(Filename:=sNameSammler, Ignorereadonlyrecommended:=True)
Set wksSammler = wbSammler.Worksheets(vBlattSammler)
'Keys der Selektion in Sammeldatei suchen und Zeilen/Zellen kopieren
For Each rngRow In rngSelektion.Rows
vKey = wksQuelle.Cells(rngRow.Row, SpalteKey).Value
Set rngZelle = wksSammler.Columns(SpalteKey).Find(What:=vKey, LookIn:=xlValues, _
lookat:=xlWhole)
With wksSammler
If rngZelle Is Nothing Then
'Neuer Schlüssel
lZeile = .Cells(.Rows.Count, SpalteKey).End(xlUp).Row + 1
Else
'vorhandener Schlüssel
lZeile = rngZelle.Row
End If
End With
With wksQuelle
If rngZelle Is Nothing Then
'Schlüssel kopieren
.Cells(rngRow.Row, SpalteKey).Copy _
Destination:=wksSammler.Cells(lZeile, SpalteKey)
End If
'selektierte Zellen kopieren
.Range(.Cells(rngRow.Row, rngRow.Column), _
.Cells(rngRow.Row, rngRow.Column + rngRow.Columns.Count - 1)).Copy _
Destination:=wksSammler.Cells(lZeile, rngRow.Column)
End With
Next
wbSammler.Close savechanges:=True
Beenden:
Fehler:
With Err
Select Case .Number
Case 0 'alles ok
Case Else
MsgBox "Fehler-Nr.: " & .Number & vbLf & .Description
End Select
End With
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub

Anzeige
AW: Zellen in anderes Arbeitsblatt kopieren
04.03.2011 08:33:57
Stefan
Hallo,
Vielen Dank für die Hilfe. Aber es ist noch folgendes Problem:
Es sollen bei markieren einer oder mehrerer Zellen nur diese Zellen in die Zieldatei kopiert werden. Im Moment wird noch die ganze Zeile in die Zieltabelle übernommen. Gibt es hierfür eine Lösung?
Vielen Dank
Grüße
Stefan

332 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige
Anzeige

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige