P
Peter
Hello everyone
The message in the subjectline is displayed when running the code below:
Option Explicit
Sub FindWeek()
Dim DateCell As Range
Dim Rownr As Integer
Dim ColumnDep As Byte
Dim ShiftDown As Byte
Dim i As Byte
Dim Dsd As String
Dim Msd As String
Dim Ysd As String
Set DateCell = Range("SearchDate")
If Range("Dsd").Value < 10 Then
Dsd = "0" & Range("Dsd").Value
Else:
Dsd = Range("Dsd").Value
End If
If Range("Msd").Value < 10 Then
Msd = "0" & Range("Msd").Value
Else:
Msd = Range("Msd").Value
End If
Ysd = Range("Ysd").Value
DateCell = Dsd & "-" & Msd & "-" & Ysd
Sheets("TotaalTabel").Select
Cells.Find(What:=DateCell.Value, After:=ActiveCell, LookIn:=xlFormulas,
_
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False).Activate
Rownr = ActiveCell.Row
ColumnDep = 7
ShiftDown = 3
For i = 1 To 16
Range(Range("SearchDate").Offset(ShiftDown, 0), Range("SearchDate").
_
Offset(ShiftDown, 6)).Copy
Cells(Rownr, ColumnDep).PasteSpecial Paste:=xlPasteValues,
Operation:=xlNone, SkipBlanks _
:=False, Transpose:=True
ShiftDown = ShiftDown + 1
ColumnDep = ColumnDep + 1
Next i
End Sub
The message in the subjectline is displayed when running the code below:
Option Explicit
Sub FindWeek()
Dim DateCell As Range
Dim Rownr As Integer
Dim ColumnDep As Byte
Dim ShiftDown As Byte
Dim i As Byte
Dim Dsd As String
Dim Msd As String
Dim Ysd As String
Set DateCell = Range("SearchDate")
If Range("Dsd").Value < 10 Then
Dsd = "0" & Range("Dsd").Value
Else:
Dsd = Range("Dsd").Value
End If
If Range("Msd").Value < 10 Then
Msd = "0" & Range("Msd").Value
Else:
Msd = Range("Msd").Value
End If
Ysd = Range("Ysd").Value
DateCell = Dsd & "-" & Msd & "-" & Ysd
Sheets("TotaalTabel").Select
Cells.Find(What:=DateCell.Value, After:=ActiveCell, LookIn:=xlFormulas,
_
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False).Activate
Rownr = ActiveCell.Row
ColumnDep = 7
ShiftDown = 3
For i = 1 To 16
Range(Range("SearchDate").Offset(ShiftDown, 0), Range("SearchDate").
_
Offset(ShiftDown, 6)).Copy
Cells(Rownr, ColumnDep).PasteSpecial Paste:=xlPasteValues,
Operation:=xlNone, SkipBlanks _
:=False, Transpose:=True
ShiftDown = ShiftDown + 1
ColumnDep = ColumnDep + 1
Next i
End Sub