Combine two routines

[bdt]

Hi all,
I have a code where I take a range of cells in a column and place them in another sheet in a row, which works fine. In my ignorance I thought I could have another similar piece of code that takes a different range of cells and puts then in the same row as the first piece of code. I didn't appreciate the second code overwrites the first. Is it possible to combine the two codes so that range AI21:AI33 and BM21:BM33 are placed in the same cells in a row on the sheet "OVERTIME". My code is;

'add overtime sunday
With ActiveSheet
WKend = .Range("M2").Value
arr = .Range("AI21:AI33").Value
End With

With Sheets("OVERTIME").Range("A:A")
Set fndRng = .Find(What:=Format(WKend, "dd/mm/yy"), _
LookIn:=xlValues, _
LookAt:=xlPart, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)

If Not fndRng Is Nothing Then
fndRng.Offset(, 1).Resize(, UBound(arr)).Value = Application.Transpose(arr)
Else
MsgBox "Sorry, did not find " & WKend
End If

End With

'add absence sunday
With ActiveSheet
WKend = .Range("M2").Value
arr = .Range("BM21:BM33").Value
End With

With Sheets("OVERTIME").Range("A:A")
Set fndRng = .Find(What:=Format(WKend, "dd/mm/yy"), _
LookIn:=xlValues, _
LookAt:=xlPart, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)

If Not fndRng Is Nothing Then
fndRng.Offset(, 1).Resize(, UBound(arr)).Value = Application.Transpose(arr)
Else
MsgBox "Sorry, did not find " & WKend
End If
End With

Many thanks again

 

[bebo021999]

range AI21:AI33 and BM21:BM33 are placed in the same cells in a row

When reading this section, I believe you want BM to overwrite AI in the same range, while you actually don’t want to do that. Please clarify the AI range and BM range; where do you want to paste them?

 

[Alex Blakenburg]

I am also unclear on where you want the 2 lots of data to finish up.
On the off chance that you want them side by side when you copy back the BM array just change the column offset from 1 to 14.

fndRng.Offset(, 14).Resize(, UBound(arr)).Value = Application.Transpose(arr)

 

[pitchoute]

Sub AddDataToOvertimeSheet()
    Dim WKend As Variant
    Dim arr1 As Variant
    Dim arr2 As Variant
    Dim fndRng As Range
    Dim arr1_len As Integer
    Dim arr2_len As Integer
    Dim totalOffset As Integer

    With ActiveSheet
        WKend = .Range("M2").Value
        arr1 = .Range("AI21:AI33").Value
        arr2 = .Range("BM21:BM33").Value
    End With

    arr1_len = UBound(arr1) - LBound(arr1) + 1
    arr2_len = UBound(arr2) - LBound(arr2) + 1

    With Sheets("OVERTIME").Range("A:A")
        Set fndRng = .Find(What:=Format(WKend, "dd/mm/yy"), _
            LookIn:=xlValues, _
            LookAt:=xlPart, _
            SearchOrder:=xlByRows, _
            SearchDirection:=xlNext, _
            MatchCase:=False)
        If Not fndRng Is Nothing Then
            totalOffset = 1 ' Starting column (Column B)

            fndRng.Offset(, totalOffset).Resize(, arr1_len).Value = Application.Transpose(arr1)
            totalOffset = totalOffset + arr1_len ' Update the offset

            fndRng.Offset(, totalOffset).Resize(, arr2_len).Value = Application.Transpose(arr2)
        Else
            MsgBox "Sorry, did not find " & WKend & " date.", vbExclamation, "Date Not Found"
        End If
    End With
End Sub

 

[bdt]

pitchoute, many thanks. So nearly does what I'm after. Looks like I was not 100% clear in my goal.
I need arr1=.Range("AI21:AI33").Value and arr2=.Range("BM21:BM33").Value to be placed into the same row AND in the same columns, B to M.
Hope this makes it a little clearer.

 

[pitchoute]

Could you update your code like this?

Sub AddDataToOvertimeSheet()
    Dim WKend As Variant
    Dim arr1 As Variant, arr2 As Variant
    Dim merged_arr As Variant
    Dim fndRng As Range
    Dim i As Integer
    Dim arr_len As Integer

    With ActiveSheet
        WKend = .Range("M2").Value
        arr1 = .Range("AI21:AI33").Value  ' 13 rows x 1 column
        arr2 = .Range("BM21:BM33").Value  ' 13 rows x 1 column
    End With

    arr_len = UBound(arr1, 1) - LBound(arr1, 1) + 1  ' Calculate array length

    ReDim merged_arr(1 To 1, 1 To arr_len)

    For i = 1 To arr_len
        If arr1(i, 1) <> "" Then
            merged_arr(1, i) = arr1(i, 1)
        ElseIf arr2(i, 1) <> "" Then
            merged_arr(1, i) = arr2(i, 1)
        Else
            merged_arr(1, i) = ""
        End If
    Next i

    With Sheets("OVERTIME").Range("A:A")
        Set fndRng = .Find(What:=Format(WKend, "dd/mm/yy"), _
            LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, _
            SearchDirection:=xlNext, MatchCase:=False)
        If Not fndRng Is Nothing Then
            fndRng.Offset(, 1).Resize(1, arr_len).Value = merged_arr
        Else
            MsgBox "Sorry, did not find " & WKend & " date.", vbExclamation, "Date Not Found"
        End If
    End With
End Sub

 

[bdt]

Many thanks for replying so soon.
[arr.Range("AI21:AI33").Value ' 13 rows x 1 column] is added where I wish but unfortunately [arr2 =.Range("BM21:BM33").Value ' 13 rows x 1 column] is not being added to any columns or rows.
[arr2 =.Range("BM21:BM33").Value ' 13 rows x 1 column] seems to clear any values put there by [arr.Range("AI21:AI33").Value ' 13 rows x 1 column] and places a "0" in its place
Cheers

 

[pitchoute]

Retry please;

Sub AddDataToOvertimeSheet()
    Dim WKend As Variant
    Dim arr1 As Variant, arr2 As Variant
    Dim merged_arr As Variant
    Dim fndRng As Range
    Dim i As Integer
    Dim arr_len As Integer

    With ActiveSheet
        WKend = .Range("M2").Value
        arr1 = .Range("AI21:AI33").Value  ' 13 rows x 1 column
        arr2 = .Range("BM21:BM33").Value  ' 13 rows x 1 column
    End With

    arr_len = UBound(arr1, 1) - LBound(arr1, 1) + 1  ' Calculate array length

    ReDim merged_arr(1 To 1, 1 To arr_len)

    For i = 1 To arr_len
        ' If arr1 has a value and it's not empty
        If Not IsEmpty(arr1(i, 1)) And arr1(i, 1) <> "" Then
            merged_arr(1, i) = arr1(i, 1)
        ' If arr1 is empty and arr2 has a value
        ElseIf Not IsEmpty(arr2(i, 1)) And arr2(i, 1) <> "" Then
            merged_arr(1, i) = arr2(i, 1)
        Else
            merged_arr(1, i) = ""
        End If
    Next i

    With Sheets("OVERTIME").Range("A:A")
        Set fndRng = .Find(What:=Format(WKend, "dd/mm/yy"), _
            LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, _
            SearchDirection:=xlNext, MatchCase:=False)
        If Not fndRng Is Nothing Then
            fndRng.Offset(, 1).Resize(1, arr_len).Value = merged_arr
        Else
            MsgBox "Sorry, did not find " & WKend & " date.", vbExclamation, "Date Not Found"
        End If
    End With
End Sub

 

[bdt]

pitchoute, I very much appreciate your response. Unfortunately arr2 is still not adding to the row in"OVERTIME"

 

[NoSparks]

I used the array for your original question in order to avoid any looping, obviously the goal post have moved.
If this is the kind of thing you're now after

bdt.xlsm
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O
1	Dates
2	07/09/24
3	14/09/24
4	21/09/24
5	28/09/24
6	05/10/24
7	12/10/24	ai_21 bm_21	ai_22 bm_22	ai_23 bm_23	ai_24 bm_24	ai_25 bm_25	ai_26 bm_26	ai_27 bm_27	ai_28 bm_28	ai_29 bm_29	ai_30 bm_30	ai_31 bm_31	ai_32 bm_32	ai_33 bm_33
8	19/10/24
9	26/10/24
10	02/11/24
11	09/11/24
12
OVERTIME

Try this

Sub testing()    ' data in same cells
    
    Dim WKend As Date
    Dim rng1 As Range, rng2 As Range
    Dim fndRng As Range, cel As Range
    Dim i As Long
    
'add overtime sunday
With ActiveSheet
    WKend = .Range("M2").Value
    Set rng1 = .Range("AI21:AI33")
    Set rng2 = .Range("BM21:BM33")
End With

With Sheets("OVERTIME").Range("A:A")
    ' find date
    Set fndRng = .Find(What:=Format(WKend, "dd/mm/yy"), _
                        LookIn:=xlValues, _
                        LookAt:=xlPart, _
                        SearchOrder:=xlByRows, _
                        SearchDirection:=xlNext, _
                        MatchCase:=False)

    If Not fndRng Is Nothing Then   'if found
        i = 1
        For Each cel In rng1
            fndRng.Offset(, i) = cel.Value
            i = i + 1
        Next cel
        i = 1
        For Each cel In rng2
            fndRng.Offset(, i) = fndRng.Offset(, i).Value & Chr(10) & cel.Value
            i = i + 1
        Next cel
    Else                            'if not found
        MsgBox "Sorry, did not find " & WKend
    End If
End With

End Sub