AW: Daten einsortieren und sammeln
Uwe
Hallo, Ralf!
Das folgende Listing für ein neues Makro, welches einen Zeitbereich in eine Datenzeitreihe einfügt, geht von folgender Umgebung aus:
- Arbeitsmappe "Webabfrage" ist geöffnet
-- Tabellenblatt "CASH-Kal" existiert
--- Spalte A: Datumsangaben, aufsteigend
--- Spalte B: Werte
--- Zelle D1 (Cells(1,4)): Name der Zieltabelle in der Arbeitsmappe "Datenzeitreihe" (s.u.)
--- Zelle D2 (Cells(2,4)): Startdatum des Übergabebereiches (ein Datum in der Spalte A)
--- Zelle D3 (Cwlls(3,4)): Enddatum des Übergabebereiches (ein Datum in der Spalte A)
- Arbeitsmappe "Datenzeitreihe" ist geöffnet
-- Tabellenblatt "Serie1" existiert
--- Spalte A: Datumsangaben, aufsteigend
--- Spalte B: Werte
Option Explicit
Sub InsertData()
Dim wsQuell As Worksheet, wsZiel As Worksheet, msg As String
Dim n As Long, gefunden As Boolean
Dim rngQuell As Range, maxR As Long
Dim Date0 As Date, r0 As Long
Dim Date1 As Date, r1 As Long
Set wsQuell = Workbooks("Webabfrage").Worksheets("CASH-Kal")
Set wsZiel = Workbooks("Datenzeitreihe").Worksheets(wsQuell.Cells(1, 4).Value)
If wsZiel Is Nothing Or wsQuell Is Nothing Then
If wsQuell Is Nothing Then
msg = "Quell"
Else
msg = "Ziel"
End If
MsgBox (msg + "Ziel nicht gefunden")
Exit Sub
End If
With wsQuell
maxR = .Cells(Rows.Count, 1).End(xlUp).Row
Date0 = .Cells(2, 4)
Date1 = .Cells(3, 4)
gefunden = False
For r0 = 1 To maxR
If .Cells(r0, 1) = Date0 Then
gefunden = True
Exit For
End If
Next
If Not (gefunden) Then
MsgBox ("Startdatum nicht gefunden")
Exit Sub
End If
gefunden = False
For r1 = r0 To maxR
If .Cells(r1, 1) = Date1 Then
gefunden = True
Exit For
End If
Next
If Not (gefunden) Then
MsgBox ("Enddatum nicht gefunden")
Exit Sub
End If
.Range("A" & r0 & ":B" & r1).Copy
n = r1 - r0 + 1
End With
With wsZiel
maxR = .Cells(Rows.Count, 1).End(xlUp).Row
gefunden = False
For r0 = 1 To maxR
If .Cells(r0, 1) > Date0 Then
'gefunden = True
Exit For
End If
Next
.Range("A" & r0).Insert Shift:=xlDown
Application.CutCopyMode = False
.Range("A" & r0 + n).Select
End With
End Sub
Gruß!