Copy comment and formatting with criteria to worksheet

[Rip1971]

Hi,

I am looking for a way to copy cell formatting and comment from 1 workbook to another based on conditions.
the layout of both workbooks is the same. see table below. rownumbers will offcourse be different

1. Get ItemID from source F2
2. Go through F:F in goal workbook
3. If UserID (A3) and ItemID (F3) are same and sourceDaysRemaining (D3) < goalDaysRemaining in (Column Dx) then
4. copy formatting from source A2 to current row Goal Ax
5. Loop to next A and F combination

Source and Goal have exact same layout. posted here is an example of the source

Rapport_Jan.xlsx
	A	B	C	D	E	F
2	User ID	First Name	Last Name	Days Remaining	Required Date	Item Id
3	NA30379	Herman	Bombeek	986	13-Sep-23	060387_1825
4	NA30379	Herman	Bombeek			DOW_797021
5	NA30379	Herman	Bombeek	1040	6-Nov-23	CP0316
6	NA30379	Herman	Bombeek			CP0322
Data

 

[Rip1971]

Giving the question a second try Hoping this is something someone can help me with.

thanks in advance.;

 

[Rip1971]

I would really appreciate if someone could help me with this issue. Since i have no idea how too start something like this. I understand it is easier to look at code and then correct it but i don't have anything to start from.

 

[Rip1971]

I have been working on a version that almost does what i want. however there is 1 part that does not work yet.
If the days remaining is negative (-100) and a month later it is more negative (-130) for some reason it does not copy the comment.
Who can help me with this it is much appreciated.

Sub Rip()
    Dim SourceWB As String, DestWB As String
    SourceWB = ThisWorkbook.Path & "\Rapport_Source.xlsx"
    DestWB = ThisWorkbook.Path & "\Rapport_Dest.xlsx"
    'Speed up code
    With Application
        .EnableEvents = False
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
        .StatusBar = False
    End With
    'Open Workbooks and get last rows used
    Dim WBs As Workbook, WBd As Workbook
    Dim LRs As Long, LRd As Long
    Workbooks.Open SourceWB
    LRs = Range("A1").End(xlDown).Row
    Set WBs = ActiveWorkbook
    '
    Workbooks.Open DestWB
    LRd = Range("A1").End(xlDown).Row
    Set WBd = ActiveWorkbook
    'Process
    Dim RWs As Long, UIDs As String, DAYs As String, IDs As String
    Dim RNGd As String, i As Long, UIDsErr As String
    Dim RWd As Long, UIDd As String, DAYd As String, IDd As String, UIDdNext As String
    Dim CntComment As Long, CntTransferred As Long, Tim As Long
    Tim = Timer
    RNGd = "A3:A" & LRd
    '
    For RWs = 3 To LRs
        'DoEvents
        Application.StatusBar = RWs & " of " & LRs
        'Only cells with comments...
        If Not (WBs.ActiveSheet.Range("a1").Offset(RWs - 1, 0).Comment Is Nothing) Then
            CntComment = CntComment + 1
            UIDs = WBs.ActiveSheet.Range("a1").Offset(RWs - 1, 0)
            DAYs = WBs.ActiveSheet.Range("a1").Offset(RWs - 1, 3)
            IDs = WBs.ActiveSheet.Range("a1").Offset(RWs - 1, 5)
            '
            If IsError(Application.Match(UIDs, WBd.ActiveSheet.Range(RNGd), 0)) Then
                If UIDs <> UIDsErr Then
                    UIDsErr = UIDs
                    MsgBox UIDs & " not found in destination file", vbOKOnly + vbInformation, AppName
                End If
            Else
                RWd = Application.Match(UIDs, WBd.ActiveSheet.Range(RNGd), 0) + 2
                UIDd = WBd.ActiveSheet.Range("a1").Offset(RWd - 1, 0)
                DAYd = WBd.ActiveSheet.Range("a1").Offset(RWd - 1, 3)
                IDd = WBd.ActiveSheet.Range("a1").Offset(RWd - 1, 5)
                'Copy (test: in column H)
                If UIDs = UIDd And IDs = IDd And DAYs > DAYd Then
                    CntTransferred = CntTransferred + 1
                    WBs.ActiveSheet.Range("a1").Offset(RWs - 1, 0).Copy
                    WBd.ActiveSheet.Range("a1").Offset(RWd - 1, 0).PasteSpecial Paste:=xlPasteFormats
                    WBd.ActiveSheet.Range("a1").Offset(RWd - 1, 0).PasteSpecial Paste:=xlPasteComments
                    WBd.ActiveSheet.Range("a1").Offset(RWd - 1, 7) = 1 'Temp counter
                    WBd.ActiveSheet.Range("a1").Offset(RWd - 1, 8) = CntComment 'Temp counter
                    WBd.ActiveSheet.Range("a1").Offset(RWd - 1, 9) = CntTransferred 'Temp counter
                End If
                'Next Destination
                RWd = RWd + 1
                UIDdNext = WBd.ActiveSheet.Range("a1").Offset(RWd - 1, 0)
                While UIDd = UIDdNext And RWd < LRd
                    DAYd = WBd.ActiveSheet.Range("a1").Offset(RWd - 1, 3)
                    IDd = WBd.ActiveSheet.Range("a1").Offset(RWd - 1, 5)
                    'Copy (test: in column H)
                    If IDs = IDd And DAYs > DAYd Then
                        CntTransferred = CntTransferred + 1
                        WBs.ActiveSheet.Range("a1").Offset(RWs - 1, 0).Copy
                        WBd.ActiveSheet.Range("a1").Offset(RWd - 1, 0).PasteSpecial Paste:=xlPasteFormats
                        WBd.ActiveSheet.Range("a1").Offset(RWd - 1, 0).PasteSpecial Paste:=xlPasteComments
                        WBd.ActiveSheet.Range("a1").Offset(RWd - 1, 7) = 1 'Temp counter
                        WBd.ActiveSheet.Range("a1").Offset(RWd - 1, 8) = CntComment 'Temp counter
                        WBd.ActiveSheet.Range("a1").Offset(RWd - 1, 9) = CntTransferred 'Temp counter
                    End If
                    RWd = RWd + 1
                    UIDdNext = WBd.ActiveSheet.Range("a1").Offset(RWd - 1, 0)
                Wend
            End If
        End If
    Next
    '
    MsgBox "Done in , " & Int(Timer - Tim) & " seconds." & vbCrLf & _
           CntComment & " comments, " & CntTransferred & " transferred to destination sheet", vbOKOnly + vbInformation, AppName
    '
    With Application
        .EnableEvents = True
        .Calculation = xlCalculationAutomatic
        .ScreenUpdating = True
        .StatusBar = False
    End With
End Sub