Makro erweitern
Tommy
Ich habe für eine Tipprunde ein Makro zum Einlesen von Tipps und möchte dieses gerne anpassen. Und zwar soll der Tipp ab Zeile 4 bis Zeile 147 eingefügt werden; dort wo die nächte leere Zeile ist quasi, damit die Tipps alle untereinander stehen.
Sub TippsEinlesen()
Dim wbZiel As Workbook, wbQuelle As Workbook, rngDaten As Range, i As Integer
Dim Bereich(1 To 3) As String
Dim Zeile(1 To 3) As Long 'Oberen Index festlegen entsprechend der Anzahl Bereiche die kpiert _
werden
Set wbZiel = Workbooks.Open(Filename:="C:\Speicherort\XXX.xls") 'Datei in die die Tipps _
kopiert werden
Bereich(1) = "A4:L4" 'Bereich, der in 1. Tabelle kopiert werden soll; hier sind Tipps
Bereich(2) = "A10:L10" 'Bereich, der in 2. Tabelle kopiert werden soll; hier sind Tipps
Bereich(3) = "A16:L16" 'Bereich, der in 3. Tabelle kopiert werden soll; hier sind Tipps
'Nächste frei Zielzeile in den Tabellen der Zieltabellen ermitteln
For i = 1 To UBound(Zeile)
With wbZiel.Sheets(i)
' Zeile(i) = .UsedRange.Row + .UsedRange.Rows.Count
'Alternative Möglichkeit
'Nachfolgend Spalte wählen in der immer Daten stehen!
Zeile(i) = .Cells(.Rows.Count, "C").End(xlUp).Row + 1
End With
Next i
Do
'Datendatei öffnen
Datei = Application.Dialogs(xlDialogOpen).Show
If Datei = False Then Exit Sub
Application.ScreenUpdating = False
Set wbQuelle = ActiveWorkbook
'Formate und Daten aus den Bereichen in die Zieltabellen kopieren
For i = 1 To UBound(Bereich)
Set rngDaten = wbQuelle.Sheets(1).Range(Bereich(i))
rngDaten.Copy
With wbZiel.Sheets(i)
.Cells(Zeile(i), "C").PasteSpecial Paste:=xlFormats
.Cells(Zeile(i), "C").PasteSpecial Paste:=xlValues
End With
Zeile(i) = Zeile(i) + 1
Next i
Application.CutCopyMode = False
wbQuelle.Close Savechanges = False
Application.ScreenUpdating = True
wbZiel.Save
Loop Until MsgBox("Weitere Datei bearbeiten?", vbQuestion + vbYesNo, "Daten einlesen") = vbNo
wbZiel.Close
End Sub