Daten aus Tagesmeldung kopieren

Sub XYZ() Application.ScreenUpdating = False 'Bildschirm einfrieren Application.DisplayAlerts = False 'Abfragen unterdrücken Dim geöffnet As Boolean Dim LWB As String Dim wb As Workbook Dim wsQuelle As Worksheet Dim wsZiel As Worksheet LWB = Left(ThisWorkbook.Path, 1) 'Berechnung des Laufwerkbuchstabens, da dieser _ je nach StO variieren kann (LWB) 'feststellen, ob Mappe bereits offen For Each wb In Application.Workbooks If wb.Name = "Liste.xlsx" Then geoeffnet = True Next wb 'entsprechend reagieren If geoeffnet Then Workbooks("Liste.xlsx").Activate Else Workbooks.Open Filename:=(LWB & ":\01_NEUE ORDNERSTRUKTUR\Liste.xlsx"), _ UpdateLinks:=0 End If a = 1 For i = 1 To 10000 With Worksheets("Tabelle1") If .Cells(i, "G") = Date Then WEITERER CODE ? Else End If End With Next i Application.ScreenUpdating = True End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub XYZ() Dim strLWB As String, booOffen As Boolean, lngZeile As Long Dim WB1 As Workbook, WB2 As Workbook Dim WS1 As Worksheet, WS2 As Worksheet Set WB1 = ThisWorkbook Set WS1 = WB1.Worksheets("Tabelle1") For Each WB2 In Application.Workbooks If WB2.Name = "Liste.xlsx" Then booOffen = True Exit For End If Next WB2 If Not booOffen Then strLWB = Left(ThisWorkbook.Path, 1) Set WB2 = Workbooks.Open(strLWB & ":\01_NEUE ORDNERSTRUKTUR\Liste.xlsx") End If Set WS2 = WB2.Worksheets("Tabelle1") If WorksheetFunction.CountIf(WS1.Columns(1), Date) = 0 Then MsgBox "Datum nicht vorhanden" Else lngZeile = Application.Match(CLng(Date), WS1.Columns(1), 0) WS2.Range("B2") = WS1.Cells(lngZeile, 2) WS2.Range("C2") = WS1.Cells(lngZeile, 3) WS2.Range("D2") = WS1.Cells(lngZeile, 5) WS2.Range("B3") = WS1.Cells(lngZeile, 4) End If End Sub

Hallo Alina,
etwa wie folgt sollte es funktionieren.
Gruß
Franz

Sub XYZ()
Application.ScreenUpdating = False       'Bildschirm einfrieren
Application.DisplayAlerts = False        'Abfragen unterdrücken
Dim geoeffnet As Boolean
Dim LWB As String
Dim wb As Workbook
Dim wsQuelle As Worksheet
Dim wsZiel As Worksheet
Dim a As Long, i As Long
LWB = Left(ThisWorkbook.Path, 1)   'Berechnung des Laufwerkbuchstabens, da dieser _
je nach StO variieren kann (LWB)
Set wsQuelle = ActiveSheet 'Aktives Tabellenblatt mit den Daten des Tages und dem Button
'feststellen, ob Mappe bereits offen
For Each wb In Application.Workbooks
If wb.Name = "Liste.xlsx" Then geoeffnet = True: Exit For
Next wb
'entsprechend reagieren
If geoeffnet Then
wb.Activate
Else
Set wb = Application.Workbooks.Open( _
Filename:=LWB & ":\01_NEUE ORDNERSTRUKTUR\Liste.xlsx", _
UpdateLinks:=0)
End If
Set wsZiel = wb.Worksheets("Tabelle1")
a = 0
With wsZiel
'Tagesdatum in Spalte A (1) der Zieltabelle suchen
For i = 1 To .Cells(.Rows.Count, 1).End(xlUp).Row
If .Cells(i, 1) = Date Then
a = i
Exit For
End If
Next i
If a > 0 Then
.Cells(a, 2) = wsQuelle.Range("B2") 'Anzahl
.Cells(a, 3) = wsQuelle.Range("C2") 'Kennziffer
.Cells(a, 4) = wsQuelle.Range("B3") 'Text
.Cells(a, 5) = wsQuelle.Range("D2") 'Gesamt
'Zieldatei speihern bzw. speichern und schliessen
If geoeffnet = True Then
wb.Save
Else
wb.Close saveChanges:=True
End If
Else
MsgBox "Datum """ & Format(Date, "DD.MM.YYYY") & """ in Zieldatei nicht gefunden!"
End If
End With
Application.ScreenUpdating = True 'Bildschirm freigeben
Application.DisplayAlerts = True 'Abfragen gestatten
End Sub

Beliebteste Forumthreads (12 Monate)

4 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

4
Beiträge zum Forumthread

Beiträge zu diesem Forumthread