Change destination between 2 sheets

[KlausW]

Hi, I have a challenge.

I use these two codes. The first to transfer data between the sheet Tilmelding and the sheet Tid.

The other code to show what data there is in the sheet Tid. This is shown in the sheet Tilmelding.

It works as it should

What I would like is for data from the sheet Tilmelding to be displayed from cell CW3 instead of cell M3 as it does now in the sheet Tid.

Any help will be appreciated.

Best regards

Klaus W

Sub Code_1()

Dim DatRng, Dest As Range
Dim TidCol, TidRow, c  As Integer

 With Sheets("Tilmelding")
    Set DatRng = .Range("C4:C10")
 On Error GoTo Ooops
    TidCol = Application.Match(.Range("A2"), Sheets("Tid").Range("1:1"), 0)
    TidRow = Application.Match(.Range("B4"), Sheets("Tid").Range("C:C"), 0)
 End With
 
For c = 0 To 2
    Set Dest = Sheets("Tid").Cells(TidRow, TidCol).Offset(0, c).Resize(7, 1)
    Dest.Value = DatRng.Offset(0, 2 * c).Value
 Next c
 
Ooops:
 If Not Err.Number = 0 Then MsgBox " Not able to match Initial or Date  -- Please check and try again"
On Error GoTo 0

Code_2

End Sub

Sub Code_2()

'If Target.Cells.Count > 1 Then Exit Sub

'If Intersect(Target, Range("A2", "G2")) Is Nothing Then Exit Sub


Dim WkRng, DestRng, SrcRng As Range

Dim TidCol, TidRow, c  As Integer


 With Sheets("Tilmelding")

    Set WkRng = .Range("B4:B10")  'Dates for week number

    Set DestRng = .Range("C4:C10")  'Required qty range

   

    On Error GoTo Ooops  'Error handler

    'TidCol = first column of initial

    'TidRow = first row of week number

       TidCol = Application.Match(.Range("A2"), Sheets("Tid").Range("1:1"), 0)

       TidRow = Application.Match(.Range("G2"), Sheets("Tid").Range("B:B"), 0)

 End With

Application.EnableEvents = False  'Stop this change event code triggereing itself and looping forever

'change the dates to match week number

WkRng.Value = Sheets("Tid").Cells(TidRow, 3).Resize(7, 1).Value


'Loop using offset to get 3 sets of data from Tid to cols C E G

For c = 0 To 2

    Set SrcRng = Sheets("Tid").Cells(TidRow, TidCol).Offset(0, c).Resize(7, 1)

    DestRng.Offset(0, 2 * c).Value = SrcRng.Value

Next c

 

Ooops:  'Error message if there is error.

 If Not Err.Number = 0 Then MsgBox " Not able to match Initial or Week Number  -- Please check and try again"


On Error GoTo 0  'set error handling back to default

Application.EnableEvents = True  're-enable events handling


End Sub

 

[DanteAmor]

What I would like is for data from the sheet Tilmelding to be displayed from cell CW3 instead of cell M3 as it does now in the sheet Tid.

Is the change only in code1?


Try (The changes are highlighted in blue):

Sub Code_1()
  Dim DatRng, Dest As Range
  Dim TidCol, TidRow, c  As Integer, col As Long
  
  With Sheets("Tilmelding")
    Set DatRng = .Range("C4:C10")
    On Error GoTo Ooops
    TidCol = Application.Match(.Range("A2"), Sheets("Tid").Range("1:1"), 0)
    TidRow = Application.Match(.Range("B4"), Sheets("Tid").Range("C:C"), 0)
  End With
   
  col = Columns("CW").Column
  For c = 0 To 2
    Set Dest = Sheets("Tid").Cells(TidRow, col).Offset(0, c).Resize(7, 1)
    Dest.Value = DatRng.Offset(0, 2 * c).Value
  Next c
   
Ooops:
  If Not Err.Number = 0 Then MsgBox " Not able to match Initial or Date  -- Please check and try again"
  On Error GoTo 0
  
  Call Code_2
End Sub

 

[KlausW]

Is the change only in code1?


Try (The changes are highlighted in blue):

Sub Code_1()
  Dim DatRng, Dest As Range
  Dim TidCol, TidRow, c  As Integer, col As Long
 
  With Sheets("Tilmelding")
    Set DatRng = .Range("C4:C10")
    On Error GoTo Ooops
    TidCol = Application.Match(.Range("A2"), Sheets("Tid").Range("1:1"), 0)
    TidRow = Application.Match(.Range("B4"), Sheets("Tid").Range("C:C"), 0)
  End With
  
  col = Columns("CW").Column
  For c = 0 To 2
    Set Dest = Sheets("Tid").Cells(TidRow, col).Offset(0, c).Resize(7, 1)
    Dest.Value = DatRng.Offset(0, 2 * c).Value
  Next c
  
Ooops:
  If Not Err.Number = 0 Then MsgBox " Not able to match Initial or Date  -- Please check and try again"
  On Error GoTo 0
 
  Call Code_2
End Sub

Good morning DanteAmor it works as it should, thank you very much. Have a nice day from Denmark Klaus W