VBA HELP Adjusment of data with if-condition

[Rene_Santos]

Hello everyone,

First of all I´d like to thank all participants on this website, which help me a lot to improve my VBA skills.

I hope to get help with my issue

Don´t get shocked about my long text, the main work is done and works.


So,

Two workbooks

1 = "CertMAIN".worksheets("RES_NEC-ISH")
2 = "IShare-Modified".worksheets(1)My current code works until now perfect where a column "B" of workbook1 is comparing
document references with column "B" in workbook 1.

When there is a match it is considering another column due to the fact that in the source workbook2,
doc refs can be three kinds of docs.
(That means one document reference number, but three times stated because of kind of document like
"CDCS", "DO" & "#CS".

Then according this the specific data like "Issue, Time Schedule & comments" will be copied in the row of match in workbook2 either in columns "W, X, Y" or "Z, AA, AB" or "AC, AD, AE", depending of the kind of document.


workbook1 Example

	A	B	C	D	E	F	G	H	I	...	W	X	Y	Z	AA	AB	AC	AD	AE
3	Project	Doc Ref	Title	Last Issue	--	--	Scheduled Date	--	--		Issue DO / FIT-T/AD	Time Sch DO / FIT-T/AD	Comments DO / FIT-T/AD	Issue CDCS	Time Sch CDCS	Comments CDCS	Issue #CS	Time Sch #CS	Comments #CS
4	--	CMM010B4450/C1S	--	2	--	--	23/2019	--	--
5	--	CMU010B3450/C1x	--	1	--	--	23/2019	--	--
6	--	CMV010B1150/C1S	--	2	--	--	17/2019	--	--
7	--	CMG010B3450/C1S	--	1	--	--	18/2019	--	--

<tbody>
</tbody>

Workbook2 Example

	A	B	C	D	E	F	G	H	I	J	K
3	--	Doc Ref	Last Issue	Kind of Doc	--	--	--	--	--	Scheduled Date	Comments
4	--	CMM010B4450/C1S	1	DO	--	--	--	--	--	15/2019	sfsdfsdf
5	--	CMM010B4450/C1S	1	CDCS	--	--	--	--	--	15/2019	sdfdgsdgg
6	--	CMM010B4450/C1S	1	#CS	--	--	--	--	--	17/2019	fdb
7	--	CMM010B4450/C1S	2	DO	--	--	--	--	--	23/2019	dfgfgg
8	--	CMM010B4450/C1S	2	CDCS	--	--	--	--	--	23/2019	wwgf

<tbody>
</tbody>

The Target is:

The code does not include to figure out that only the latest issue of the corresponding doc ref and kind of doc has to be copied. As you can see that doc refs can be listet several time with different Issues (Revisions).
Only the data of the latest Issue shall be copied to the corresponding columns "W, X, Y" or "Z, AA, AB" or "AC, AD, AE"

I highly appreciate when someone can modify my exisiting code as shown as follow

Sub CompareCopy()


Dim lngRow As Long, lngRowLast As Long
Dim avarData As Variant
Dim x As Long
Dim dictArrayIndexSrc As Object 'strKey:= DocRef#KindOf, item:= Array-Index
Dim varStrKey As Variant 'Key should always be defined as "String" to exclude problems with numbers
Dim strDocRef As String
Dim lngIndex As Long
Dim avarOutput As Variant
Dim wb2 As Workbook
Dim r As range
Dim wb1 As Workbook
Dim ws1 As Worksheet


Set wb1 = ThisWorkbook
Set ws1 = wb1.Worksheets("RES_NEC-ISH")
Set wb2 = Workbooks.Open("P:...\IShare-Modified.xlsx", False, False)


    'Source-Data read-in
        With wb2.Worksheets(1)
    'clear filter
        Call ClearAllFilterInWks(.range("A1").Parent) 'Detour, to prevent to rewriting Wks
    'last row
        lngRowLast = .Cells(.Rows.Count, "b").End(xlUp).row 'last row in cloumn B
    'Data read-out
        avarData = range(.range("B4"), .Cells(lngRowLast, "k"))
        End With


    'Dictionary - creating and filling
        Set dictArrayIndexSrc = CreateObject("Scripting.Dictionary")
        For x = 1 To UBound(avarData)
            If avarData(x, 3) = "FIT_TAD" Or avarData(x, 3) = "FT" Or avarData(x, 3) = "FIT/TAD" Then
                'Kind of Doc "FIT_TAD" and "FIT/TAD" and "FT" correspond to "DO"
                    varStrKey = CStr(avarData(x, 1) & "#" & "DO")
                Else
                    varStrKey = CStr(avarData(x, 1) & "#" & avarData(x, 3))
            End If
            
            If dictArrayIndexSrc.Exists(varStrKey) Then
                'Element is existing
                Debug.Print varStrKey & " existiert bereits"
                Debug.Print "erste Zeile: " & dictArrayIndexSrc(varStrKey) + 3 & " aktuelle Zeile: " & x + 3
                Else
                    'Element is not existing
                    dictArrayIndexSrc.Add varStrKey, x
            End If
            
        Next


        'Dst write
    With ThisWorkbook.Worksheets("RES_NEC-ISH")
        'clear
            Call ClearAllFilterInWks(.range("A1").Parent) 'Detour, to prevent to rewriting Wks
        'last row
            lngRowLast = .Cells(.Rows.Count, "b").End(xlUp).row 'last row in cloumn B
        'Output-Arry redimensionieren
            ReDim avarOutput(1 To lngRowLast - 3, 1 To 9) As Variant
        'Output-data writing in Array
        For lngRow = 4 To lngRowLast
            strDocRef = .Cells(lngRow, "b").Value
            
            'DO ("FIT_TAD" and "FT" already converted into "DO" as above)
            If dictArrayIndexSrc.Exists(strDocRef & "#" & "DO") Then
                'Element is existing
                lngIndex = dictArrayIndexSrc(strDocRef & "#" & "DO")
                avarOutput(lngRow - 3, 1) = avarData(lngIndex, 2) 'Last Issue
                avarOutput(lngRow - 3, 2) = avarData(lngIndex, 9) 'Scheduled Date
                avarOutput(lngRow - 3, 3) = avarData(lngIndex, 10) 'Comments
                
                Else
                    'Element is not existing
                    avarOutput(lngRow - 3, 1) = "NA"
                    avarOutput(lngRow - 3, 2) = "NA"
                    avarOutput(lngRow - 3, 3) = "NA"
            End If
            
        'CDCS
            If dictArrayIndexSrc.Exists(strDocRef & "#" & "CDCS") Then
                'Element is existing
                lngIndex = dictArrayIndexSrc(strDocRef & "#" & "CDCS")
                avarOutput(lngRow - 3, 4) = avarData(lngIndex, 2) 'Last Issue
                avarOutput(lngRow - 3, 5) = avarData(lngIndex, 9) 'Scheduled Date
                avarOutput(lngRow - 3, 6) = avarData(lngIndex, 10) 'Comments
                
                Else
                    'Element is not existing
                    avarOutput(lngRow - 3, 4) = "NA"
                    avarOutput(lngRow - 3, 5) = "NA"
                    avarOutput(lngRow - 3, 6) = "NA"
            End If
            
        '#CS
            If dictArrayIndexSrc.Exists(strDocRef & "#" & "#CS") Then
                'Element is existing
                lngIndex = dictArrayIndexSrc(strDocRef & "#" & "#CS")
                avarOutput(lngRow - 3, 7) = avarData(lngIndex, 2) 'Last Issue
                avarOutput(lngRow - 3, 8) = avarData(lngIndex, 9) 'Scheduled Date
                avarOutput(lngRow - 3, 9) = avarData(lngIndex, 10) 'Comments
                
                Else
                    'Element is not existing
                    avarOutput(lngRow - 3, 7) = "NA"
                    avarOutput(lngRow - 3, 8) = "NA"
                    avarOutput(lngRow - 3, 9) = "NA"
            End If
            
        Next
            'Output-data writing in Wks
            .range("W4").Resize(UBound(avarOutput, 1), UBound(avarOutput, 2)).Value = avarOutput
    
    End With


'Straighting up
Set dictArrayIndexSrc = Nothing


'Rows will be adjusted
    ThisWorkbook.Activate
        Sheets("RES_NEC-ISH").Select
        ws1.range("A4:A" & ws1.Rows.Count).RowHeight = 11.25




Workbooks("IShare-Modified.xlsx").Close


End Sub


Private Sub ClearAllFilterInWks(wks As Worksheet)
Dim tbl As ListObject
With wks
    'AutoFilter
    If .AutoFilterMode = True Then 'AutoFilter is existing
        If .FilterMode = True Then .ShowAllData 'AutoFilter is active
    End If
    'table filter
    For Each tbl In .ListObjects
        With tbl
            If .ShowAutoFilter = True Then 'tabel filter exists
                If .AutoFilter.FilterMode = True Then 'table filter is active
                    .ShowAutoFilter = False 'turn off
                    .ShowAutoFilter = True 'turn on (clear all former enabled filter)
                End If
            End If
        End With
    Next
End With
End Sub

Thank you in advance!


Best Regards
René