kopieren mit Makro

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub Kopieren() Dim WkSh_Q As Worksheet Dim WkSh_Z As Worksheet Dim lZeile_Q As Long Dim lZeile_Z As Long Dim iSpalte As Integer Dim bLeer As Boolean Set WkSh_Q = Worksheets("Tabelle1") Set WkSh_Z = Worksheets("Tabelle2") For lZeile_Q = 40 To 45 If WkSh_Q.Range("H" & lZeile_Q).Value = "" Then bLeer = True Exit For End If Next lZeile_Q If bLeer = True Then MsgBox "die Zellen H40 bis H45 sind nicht gefüllt - Abbruch.", _ 48, " Hinweis für " & Application.UserName Exit Sub End If lZeile_Z = WkSh_Z.Range("A65536").End(xlUp).Row + 1 iSpalte = 1 For lZeile_Q = 40 To 55 WkSh_Q.Range("H" & lZeile_Q).Copy Destination:=WkSh_Z.Cells(lZeile_Z, iSpalte) iSpalte = iSpalte + 1 If lZeile_Q = 45 Then lZeile_Q = 50 Next lZeile_Q End Sub

Sub DatenKopieren() Dim wbZiel As Workbook, wbQuelle As Workbook, rngDaten1 As Range, rngDaten2 As Range Dim Zeile As Long, QTab As Variant, ZTab As Variant Set wbZiel = ActiveWorkbook 'Datei in die die Daten kopiert werden sollen ZTab = 2 ' Nummer der Zieltabelle, hier kann auch ein Name angegeben werden Set wbQuelle = ActiveWorkbook 'Datei aus der die Daten kommen QTab = 1 ' Nummer der Zieltabelle, hier kann auch ein Name angegeben werden Set rngDaten1 = wbQuelle.Sheets(QTab).Range("H40:H45") Set rngDaten2 = wbQuelle.Sheets(QTab).Range("H50:H55") 'Überprüfung ob alle Zellen ausgefüllt sind If Application.WorksheetFunction.CountA(rngDaten1) < rngDaten1.Cells.Count Then MsgBox "im Bereich " & rngDaten1.Address & " sind nicht alle Zellen ausgefüllt!" Exit Sub End If Application.ScreenUpdating = False With wbZiel.Sheets(ZTab) 'Nächste freie Zeile in Zieltabelle ermitteln Zeile = .UsedRange.Row + .UsedRange.Rows.Count 'Alternative Möglichkeit 'Nachfolgend Spalte wählen in der immer Daten stehen! 'Zeile(i) = .Cells(.Rows.Count, "A").End(xlUp).Row + 1 '1. Bereich Kopieren und Inhalte einfügen rngDaten1.Copy '.Cells(Zeile, "A").PasteSpecial Paste:=xlFormats, Transpose:=True 'Formate .Cells(Zeile, "A").PasteSpecial Paste:=xlValues, Transpose:=True 'Werte '2. Bereich Kopieren und Inhalte einfügen rngDaten2.Copy '.Cells(Zeile, "G").PasteSpecial Paste:=xlFormats, Transpose:=True 'Formate .Cells(Zeile, "G").PasteSpecial Paste:=xlValues, Transpose:=True 'Werte End With Application.CutCopyMode = False Application.ScreenUpdating = True End Sub

Hallo Ihr Lieben nochmals vielen Dank für die Makros mit der echt guten Erklärung
-Einfach Super von Euch
-
Problem mit Peters Datei
Die Zahlen und der Text in den Zellen H40 bis H55 kommen aus anderen Zellen (in H40 steht z.Bsp die Formel = E3 weil die Daten aus anderen Zellen kommen ) Nun bekomme ich in Tabellenblatt 2 nur #BEZUG! angezeigt. Auch erkennt er irgendwie nicht das nichts in der Zelle steht wenn dort die Formel = E3 drinsteht.
Problem mit Datei von Franz
Da im Tabellenblatt 2 ab Spalte J bis N Zahlen und Text stehen setzt das Makro die übertragenen Werte ganz ans Ende der Tabelle. Spalten sind schon ausgefüllt bis Zeile 2000
Ihr Lieben wenn Ihr Euch noch einmal kurz mit meinem Problem beschäftigen könntet.
Vielen Vielen Dank
Carola

'Nächste freie Zeile in Zieltabelle ermitteln 'Zeile = .UsedRange.Row + .UsedRange.Rows.Count 'Alternative Möglichkeit 'Nachfolgend Spalte wählen in der immer Daten stehen! Zeile = .Cells(.Rows.Count, "A").End(xlUp).Row + 1

Sub DatenKopieren() Dim wbZiel As Workbook, wbQuelle As Workbook, rngDaten1 As Range, rngDaten2 As Range Dim Zeile As Long, QTab As Variant, ZTab As Variant, Zelle As Range, Test As Boolean Set wbZiel = ActiveWorkbook 'Datei in die die Daten kopiert werden sollen ZTab = 2 ' Nummer der Zieltabelle, hier kann auch ein Name angegeben werden Set wbQuelle = ActiveWorkbook 'Datei aus der die Daten kommen QTab = 1 ' Nummer der Zieltabelle, hier kann auch ein Name angegeben werden Set rngDaten1 = wbQuelle.Sheets(QTab).Range("H40:H45") Set rngDaten2 = wbQuelle.Sheets(QTab).Range("H50:H55") 'Überprüfung ob alle Zellen ausgefüllt sind Test = True For Each Zelle In rngDaten1 If Zelle.Value = "" Then Test = False Exit For End If Next If Test = False Then MsgBox "im Bereich " & rngDaten1.Address & " sind nicht alle Zellen ausgefüllt!" Exit Sub End If Application.ScreenUpdating = False With wbZiel.Sheets(ZTab) 'Nächste freie Zeile in Spalte A der Zieltabelle ermitteln 'Nachfolgend Spalte wählen in der immer Daten stehen! Zeile = .Cells(.Rows.Count, "A").End(xlUp).Row + 1 '1. Bereich Kopieren und Inhalte einfügen rngDaten1.Copy '.Cells(Zeile, "A").PasteSpecial Paste:=xlFormats, Transpose:=True 'Formate .Cells(Zeile, "A").PasteSpecial Paste:=xlValues, Transpose:=True 'Werte '2. Bereich Kopieren und Inhalte einfügen rngDaten2.Copy '.Cells(Zeile, "G").PasteSpecial Paste:=xlFormats, Transpose:=True 'Formate .Cells(Zeile, "G").PasteSpecial Paste:=xlValues, Transpose:=True 'Werte End With Application.CutCopyMode = False Application.ScreenUpdating = True End Sub

Hallo Carola,
leider hast du nicht erwähnt, dass deine Daten aus Formeln erzeugt werden.
Dann geht es so:
'
' die Zellen H40 bis H55 werden über Formel gefüllt !!!
'
Public


Sub Kopieren()
Dim WkSh_Q    As Worksheet  ' Quell-TabellenblattT
Dim WkSh_Z    As Worksheet  ' Ziel-Tabellenblatt
Dim lZeile_Q  As Long       ' Zeilen-Index Quell-Tabellenblatt
Dim lZeile_Z  As Long       ' Zeilen-Index Ziel-Tabellenblatt
Dim iSpalte   As Integer    ' die Spalte A bis K im Ziel-Tabellenblatt
Dim bLeer     As Boolean    ' Schalter für alle Zellen H40:H45 gefüllt
Application.ScreenUpdating = False  ' kein Bildschirm-Update
Set WkSh_Q = Worksheets("Tabelle1") ' Quell-Tabellenblatt
Set WkSh_Z = Worksheets("Tabelle2") ' Ziel-Tabellenblatt
For lZeile_Q = 40 To 45  ' prüfen ob H40:H45 gefüllt ist
If WkSh_Q.Range("H" & lZeile_Q).Value = "" Or _
Len(WkSh_Q.Range("H" & lZeile_Q).Value) = 0 Then
bLeer = True       ' merken, wenn eine Zelle nicht gefüllt ist
Exit For           ' und For/Next sofort verlassen
End If
Next lZeile_Q
If bLeer = True Then     ' gab es eine leere Zelle?
MsgBox "die Zellen H40 bis H45 sind nicht alle gefüllt - Abbruch.", _
48, "   Hinweis für " & Application.UserName
Exit 

Sub              ' 

Sub Sofort verlassen - nicht kopieren
End If
'   erste freie Zeile im Ziel-Tabellenblatt finden
lZeile_Z = WkSh_Z.Range("A65536").End(xlUp).Row + 1
iSpalte = 1              ' Spalte auf "A" = 1 setzen
For lZeile_Q = 40 To 55  ' von Quell-Zeile 40 bis 55
WkSh_Z.Cells(lZeile_Z, iSpalte).Value = WkSh_Q.Range("H" & lZeile_Q).Value
iSpalte = iSpalte + 1               ' nächste Spalte
If lZeile_Q = 45 Then lZeile_Q = 49 ' Zeile 45 kopiert, dann bei 50 weiter
Next lZeile_Q
Application.ScreenUpdating = False  ' Bildschirm-Update wieder zulassen
End Sub


Viele Grüße Peter

Eine kurze Nachricht, ob es läuft, wäre nett - danke.

Beliebteste Forumthreads (12 Monate)

12 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

12
Beiträge zum Forumthread

Beiträge zu diesem Forumthread