Copy paste date value to last row in nested loop-CodePudding

Got a bunch of worksheets in the same workbook that have a specific range of interest that starts with finding string 'Green'. Let's call this Range (A) that I'm interested in copying and pasting into a master sheet to form a database in same workbook. I found some useful code and got this part to work gr8!

There is a date value in each worksheet in cell(3,3). What's missing is adding this date value from each worksheet and past it to column B in the master sheet 'Main' such that the date value extends to match the length of the pasted Range (A).

all help is appreciated

Sub FindRangeHistory()

'// in MainDB workbook for each trade sheet, copy and paste specific range into 'Main' sheet

    Dim fnd As String, faddr As String
    Dim rng As Range, foundCell As Range
    Dim ws As Worksheet


    Dim ws_count As Integer, i As Integer
    ws_count = ThisWorkbook.Worksheets.Count
    
For i = 1 To ws_count
    
    With ThisWorkbook
    
    'initialize main sheet and keyword search
        Set ws = .Worksheets("Main")
        fnd = "New Life"

    'Search for keyword in sheet
        With .Worksheets(i)
            Set foundCell = .Cells.Find(What:=fnd, after:=.Cells.SpecialCells(xlCellTypeLastCell), _
                                        LookIn:=xlFormulas, LookAt:=xlWhole, _
                                        SearchOrder:=xlByRows, SearchDirection:=xlNext)
            'Test to see if anything was found
            If Not foundCell Is Nothing Then
                faddr = foundCell.Address
                Set rng = .Range(foundCell, foundCell.End(xlDown))
                Do
                    Set rng = Union(rng, .Range(foundCell, foundCell.End(xlDown)).Resize(, 7))
                    Set foundCell = .Cells.FindNext(after:=foundCell)
                Loop Until foundCell.Address = faddr

                Set rng = rng.Offset(1, 0)
                rng.Copy
                ws.Cells(Rows.Count, "C").End(xlUp).PasteSpecial Paste:=xlPasteValues


                Worksheets(i).Cells(3, 3).Copy
                ws.Cells(Rows.Count, "B").End(xlUp).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
           End If
        End With
    End With
Next i
    
End Sub

CodePudding user response：

You could do it like this:

'...
'...
Dim nextRowC As Long, lastRowC As Long

nextRowC = ws.Cells(Rows.Count, "C").End(xlUp).Row   1 'first empty row in ColC before paste

rng.Copy
ws.Cells(nextRowC, "C").PasteSpecial Paste:=xlPasteValues

lastRowC = ws.Cells(Rows.Count, "C").End(xlUp).Row     'last used row in ColC after paste

.Worksheets(i).Cells(3, 3).Copy
ws.Range(ws.Cells(nextRowC, "B"), ws.Cells(lastRowC, "B")). _
           PasteSpecial Paste:=xlPasteValuesAndNumberFormats

'...
'...