Makro erweitern
Franky
Diese Aufgabe richtet sich vorwiegend an Josef Ehrensberger, der mir dieses Makro programmiert hat.
Dieses Makro, was mir Bereiche anhand einer Datumsüberprüfung in eine Zieltabelle kopiert, möchte ich erweitern:
Es sollen 10 unterschiedliche Bereiche aus der Mastertabelle in die Zieltabelle kopiert werden.
z.B.:
1. ("A2:M2")
2. ("B3:B15")
3. ("C4:C20")
4. ("D5:D29")
5. ("E6:E20")
6. ("F7:F20")
7. ("G8:G20")
8. ("H9:H30")
9. ("I10:I40")
10.("J11:J50")
Bisher habe ich jeweils 10 Markos mit den unterschiedlichen Bereichen einzeln aufgerufen. Das ist aber ziemlich umständlich.
Sicherlich könnte man alle 10 Makros zusammenpacken in ein Modul, und mittels Call - Anweisung aufrufen. Das ist aber auch nicht passend, weil man 10 mal das gleiche Datum eingeben muss.
Vielleicht kann man das Makro so umgestalten mit einer Case-Anweisung, wo man die 10 unterschiedlichen Bereiche festlegt. Wenn man dann das Makro startet, braucht man nur einmal das Datum eintragen und alle unterschiedlichen 10 Bereiche werden kopiert.
Wer hat eine Idee?
Vielen Dank im voraus !
Franky
Sub Inhalte_einfügen2()
Dim objMaster As Worksheet, objTarget As Worksheet
Dim lngDate As Long
Dim vntTarget As Variant
Dim bolCopy As Boolean
lngDate = Application.InputBox("Bitte Datum eingeben", "Daten Kopieren", _
Format(Date, "dd.MM.yyyy"), Type:=1)
Set objMaster = ThisWorkbook.Sheets("Mastertabelle")
Set objTarget = Workbooks("liste.xlsx").Sheets("Zieltabelle")
With objMaster
If IsDate(CDate(lngDate)) Then
vntTarget = Application.Match(lngDate, objTarget.Columns(1), 0)
If IsNumeric(vntTarget) Then
bolCopy = Application.CountA(objTarget.Range(objTarget.Cells(vntTarget, 2), _
objTarget.Cells(vntTarget, 14))) = 0
If Not bolCopy Then bolCopy = MsgBox("In der Zieltabelle sind bereits Werte vorhanden!" _
_
& _
vbLf & "Wollen Sie die Werte überschreiben?", vbQuestion + vbYesNo, "Hinweis") = _
vbYes
If bolCopy Then
.Range("A2:M2").Copy
objTarget.Cells(vntTarget, 2).PasteSpecial xlPasteValues
Application.CutCopyMode = False
objTarget.Range(objTarget.Cells(vntTarget, 2), _
objTarget.Cells(vntTarget, 14)).Replace What:="0", Replacement:="", _
LookAt:=xlWhole, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
MsgBox "Werte wurden erfolgreich übertragen!", vbInformation, "Hinweis"
End If
Else
MsgBox "Datum in Zieltabelle nicht gefunden" & vbLf & "Werte wurden nicht übertragen!", _
_
_
vbExclamation, "Hinweis"
End If
Else
MsgBox "Datumseingabe ungültig!" & vbLf & "Werte wurden nicht übertragen!", vbExclamation, _
_
_
"Hinweis"
End If
End With
Set objMaster = Nothing
Set objTarget = Nothing
End Sub