HERBERS Excel-Forum - das Archiv
Thema: Daten per VBA kopieren mit 2 Kreterien | Herbers Excel-Forum
Daten per VBA kopieren mit 2 Kreterien
Jan
Hallo, ich hab folgendes Problem und bitte um hilfe:
Ich verwende eine Datei mit ca. 20 fest benamten Tabellenblättern.
Im ersten Blatt ist eine Matrix in der im Bereich b2:b21 die Namen der Tabellenblätter untereinander stehen.
In Spalte c2:c21 wird nach Bedarf etwas eingetragen.
In Zelle E1 ist die Formel Heute() eingetragen
Alle anderen Tabellenblätter haben in Spalte A4:A30 jeweils das Tagesdatum des laufenden Monats untereinander. B4:B34 ist der Zielbereich für die aus Tabellenblatt1 kommenden Daten (hier C?)
Ziel soll sein per Macro die Daten aus Tabellenblatt 1 in das zugehörige Tabellenblatt und dort in die Zeile einzutragen, die das gleiche Datum hat wie im Tabellenblatt 1 E1.
Anders ausgedrückt : Finde das richtige tabellenblatt, vergleiche dann das Datum und kopiere die Daten aus c zum richtigen Datum in die Zelle B?
Ich hoffe mir kann jemand helfen
Dank vorab
Gruß
Jan
AW: Daten per VBA kopieren mit 2 Kreterien
Josef
Hallo Jan,
na dann probier mal.
' **********************************************************************
' Modul: Modul2 Typ: Allgemeines Modul
' **********************************************************************
Option Explicit
Sub copyData()
Dim rng As Range
Dim vntRet As Variant
With Sheets(1)
For Each rng In .Range("B2:B21")
If rng <> "" And rng.Offset(0, 1) <> "" Then
If SheetExist(rng.Text) Then
vntRet = Application.Match(.Range("E1"), Sheets(rng.Text).Range("A4:A30"), 0)
If IsNumeric(vntRet) Then
Sheets(rng.Text).Cells(vntRet + 3, 2) = rng.Offset(0, 1).Value
End If
End If
End If
Next
End With
End Sub
Private Function SheetExist(ByVal sheetName As String, Optional Wb As Workbook) As Boolean
Dim wks As Worksheet
On Error GoTo ERRORHANDLER
If Wb Is Nothing Then Set Wb = ThisWorkbook
For Each wks In Wb.Worksheets
If wks.Name = sheetName Then SheetExist = True: Exit Function
Next
ERRORHANDLER:
SheetExist = False
End Function
' Modul: Modul2 Typ: Allgemeines Modul
' **********************************************************************
Option Explicit
Sub copyData()
Dim rng As Range
Dim vntRet As Variant
With Sheets(1)
For Each rng In .Range("B2:B21")
If rng <> "" And rng.Offset(0, 1) <> "" Then
If SheetExist(rng.Text) Then
vntRet = Application.Match(.Range("E1"), Sheets(rng.Text).Range("A4:A30"), 0)
If IsNumeric(vntRet) Then
Sheets(rng.Text).Cells(vntRet + 3, 2) = rng.Offset(0, 1).Value
End If
End If
End If
Next
End With
End Sub
Private Function SheetExist(ByVal sheetName As String, Optional Wb As Workbook) As Boolean
Dim wks As Worksheet
On Error GoTo ERRORHANDLER
If Wb Is Nothing Then Set Wb = ThisWorkbook
For Each wks In Wb.Worksheets
If wks.Name = sheetName Then SheetExist = True: Exit Function
Next
ERRORHANDLER:
SheetExist = False
End Function
Gruß Sepp
AW: Daten per VBA kopieren mit 2 Kreterien
Jan
Hallo Sepp,
Klappt super, vielen Dank
Gruß Jan
AW: Daten per VBA kopieren mit 2 Kreterien
Jan
Hallo Sepp,
Klappt super, vielen Dank
Gruß Jan
Excel-Beispiele