Microsoft Excel

Herbers Excel/VBA-Archiv

Daten per VBA kopieren mit 2 Kreterien | Herbers Excel-Forum


Betrifft: Daten per VBA kopieren mit 2 Kreterien von: Jan
Geschrieben am: 08.01.2010 21:57:40

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

  

Betrifft: AW: Daten per VBA kopieren mit 2 Kreterien von: Josef Ehrensberger
Geschrieben am: 08.01.2010 22:13:28

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



Gruß Sepp



  

Betrifft: AW: Daten per VBA kopieren mit 2 Kreterien von: Jan
Geschrieben am: 08.01.2010 22:27:18

Hallo Sepp,

Klappt super, vielen Dank

Gruß Jan


  

Betrifft: AW: Daten per VBA kopieren mit 2 Kreterien von: Jan
Geschrieben am: 08.01.2010 22:27:41

Hallo Sepp,

Klappt super, vielen Dank

Gruß Jan


Beiträge aus den Excel-Beispielen zum Thema "Daten per VBA kopieren mit 2 Kreterien"