Kopieren von Daten aus Abfrage
29.05.2020 08:11:00
Daten
Das unten stehende Makro ermittelt über die Eingabe der Kalenderwoche aus einer 2ten Tabelle "Übersicht" alle Lehrgänge die in dem Zeitpunkt beginnen und kopiert mir die in eine neue Tabelle auf Seite "IAMS-Eingabe"
Dort werden dann aus der Übersicht die zu dem Datum gehörenden Zellen B/C/D/E kopiert.
Ich hoffe, der der sich auskennt erkennt das anhand des Makros.
Nun würde ich aber gerne aus dem Datensatz auch noch F kopieren und I. Wenn man mir in das Makro mit Kommentaren schreiben könnte was ich verändern müsste wäre das toll. Kann auch gleich geändert werden. Dann aber bitte zuschreiben was. Ich möchte das mal etwas verstehen.
Sub iams_melden()
Dim zeile As Integer
Dim b As Integer
Dim c As Integer
Dim d As Integer
Dim az As Date
Dim ez As Date
Dim lg As Variant
Dim t As Date
Dim datum As Date
Dim bz As Variant
Dim kw As Integer
Unprotect (daten)
Application.ScreenUpdating = False
Range("b6:e1000").Select
Selection.Clear
Range("B6").Select
bz = Sheets("übersicht").Cells(6, 3).Value
c = Year(bz)
c = 5
kw = Cells(3, 5).Value
d = kw
b = 5
1:
b = b + 1
t = Sheets("übersicht").Cells(b, 3).Value
If Sheets("übersicht").Cells(b, 2).Value = "" Then GoTo ende
datum = t
Go
Sub kw
If kw = d And Cells(3, 3).Value = Year(Sheets("übersicht").Cells(b, 3).Value) Then GoTo 2
GoTo 1
2:
az = Sheets("übersicht").Cells(b, 3).Value
ez = Sheets("übersicht").Cells(b, 4).Value
lg = Sheets("übersicht").Cells(b, 2).Value
bz = Sheets("übersicht").Cells(b, 5).Value
c = c + 1
Sheets("iams-eingabe").Cells(c, 2) = lg
Sheets("iams-eingabe").Cells(c, 3) = az
Sheets("iams-eingabe").Cells(c, 4) = ez
Sheets("iams-eingabe").Cells(c, 5) = bz
Range(Cells(c, 2), Cells(c, 5)).Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
GoTo 1
GoTo ende
kw:
kw = Int((datum - DateSerial(Year(datum), 1, 1) + ((Weekday(DateSerial(Year(datum), 1, 1)) + 1) _
_
Mod 7) - 3) / 7) + 1
Return
ende:
Application.ScreenUpdating = True
Range("e3").Select
Protect (daten)
End Sub