VBA HELP Adjusment of data with if-condition

R

Rene_Santos

New Member
Joined
Jul 23, 2019
Messages
1
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 :smile:

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
[TABLE="class: cms_table_cms_table_grid, width: 500"]
<tbody>[TR]
[TD][/TD]
[TD]A[/TD]
[TD]B[/TD]
[TD]C[/TD]
[TD]D[/TD]
[TD]E[/TD]
[TD]F[/TD]
[TD]G[/TD]
[TD]H[/TD]
[TD]I[/TD]
[TD]...[/TD]
[TD]W[/TD]
[TD]X[/TD]
[TD]Y[/TD]
[TD]Z[/TD]
[TD]AA[/TD]
[TD]AB[/TD]
[TD]AC[/TD]
[TD]AD[/TD]
[TD]AE[/TD]
[/TR]
[TR]
[TD]3[/TD]
[TD]Project[/TD]
[TD]Doc Ref[/TD]
[TD]Title[/TD]
[TD]Last
Issue[/TD]
[TD]--[/TD]
[TD]--[/TD]
[TD]Scheduled Date[/TD]
[TD]--[/TD]
[TD]--[/TD]
[TD][/TD]
[TD]Issue
DO /
FIT-T/AD[/TD]
[TD]Time Sch
DO / FIT-T/AD[/TD]
[TD]Comments
DO / FIT-T/AD[/TD]
[TD]Issue
CDCS[/TD]
[TD]Time Sch
CDCS[/TD]
[TD]Comments
CDCS[/TD]
[TD]Issue
#CS[/TD]
[TD]Time Sch
#CS[/TD]
[TD]Comments
#CS[/TD]
[/TR]
[TR]
[TD]4[/TD]
[TD]--[/TD]
[TD]CMM010B4450/C1S[/TD]
[TD]--[/TD]
[TD]2[/TD]
[TD]--[/TD]
[TD]--[/TD]
[TD]23/2019[/TD]
[TD]--[/TD]
[TD]--[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]5[/TD]
[TD]--[/TD]
[TD]CMU010B3450/C1x[/TD]
[TD]--[/TD]
[TD]1[/TD]
[TD]--[/TD]
[TD]--[/TD]
[TD]23/2019[/TD]
[TD]--[/TD]
[TD]--[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]6[/TD]
[TD]--[/TD]
[TD]CMV010B1150/C1S[/TD]
[TD]--[/TD]
[TD]2[/TD]
[TD]--[/TD]
[TD]--[/TD]
[TD]17/2019[/TD]
[TD]--[/TD]
[TD]--[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]7[/TD]
[TD]--[/TD]
[TD]CMG010B3450/C1S[/TD]
[TD]--[/TD]
[TD]1[/TD]
[TD]--[/TD]
[TD]--[/TD]
[TD]18/2019[/TD]
[TD]--[/TD]
[TD]--[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
</tbody>[/TABLE]



Workbook2 Example
[TABLE="class: cms_table_cms_table_grid, width: 500"]
<tbody>[TR]
[TD][/TD]
[TD]A[/TD]
[TD]B[/TD]
[TD]C[/TD]
[TD]D[/TD]
[TD]E[/TD]
[TD]F[/TD]
[TD]G[/TD]
[TD]H[/TD]
[TD]I[/TD]
[TD]J[/TD]
[TD]K[/TD]
[/TR]
[TR]
[TD]3[/TD]
[TD]--[/TD]
[TD]Doc Ref[/TD]
[TD]Last
Issue[/TD]
[TD]Kind
of
Doc[/TD]
[TD]--[/TD]
[TD]--[/TD]
[TD]--[/TD]
[TD]--[/TD]
[TD]--[/TD]
[TD]Scheduled
Date[/TD]
[TD]Comments[/TD]
[/TR]
[TR]
[TD]4[/TD]
[TD]--[/TD]
[TD]CMM010B4450/C1S[/TD]
[TD]1[/TD]
[TD]DO[/TD]
[TD]--[/TD]
[TD]--[/TD]
[TD]--[/TD]
[TD]--[/TD]
[TD]--[/TD]
[TD]15/2019[/TD]
[TD]sfsdfsdf[/TD]
[/TR]
[TR]
[TD]5[/TD]
[TD]--[/TD]
[TD]CMM010B4450/C1S[/TD]
[TD]1[/TD]
[TD]CDCS[/TD]
[TD]--[/TD]
[TD]--[/TD]
[TD]--[/TD]
[TD]--[/TD]
[TD]--[/TD]
[TD]15/2019[/TD]
[TD]sdfdgsdgg[/TD]
[/TR]
[TR]
[TD]6[/TD]
[TD]--[/TD]
[TD]CMM010B4450/C1S[/TD]
[TD]1[/TD]
[TD]#CS[/TD]
[TD]--[/TD]
[TD]--[/TD]
[TD]--[/TD]
[TD]--[/TD]
[TD]--[/TD]
[TD]17/2019[/TD]
[TD]fdb[/TD]
[/TR]
[TR]
[TD]7[/TD]
[TD]--[/TD]
[TD]CMM010B4450/C1S[/TD]
[TD]2[/TD]
[TD]DO[/TD]
[TD]--[/TD]
[TD]--[/TD]
[TD]--[/TD]
[TD]--[/TD]
[TD]--[/TD]
[TD]23/2019[/TD]
[TD]dfgfgg[/TD]
[/TR]
[TR]
[TD]8[/TD]
[TD]--[/TD]
[TD]CMM010B4450/C1S[/TD]
[TD]2[/TD]
[TD]CDCS[/TD]
[TD]--[/TD]
[TD]--[/TD]
[TD]--[/TD]
[TD]--[/TD]
[TD]--[/TD]
[TD]23/2019[/TD]
[TD]wwgf[/TD]
[/TR]
</tbody>[/TABLE]



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
Code: 
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é
 

Excel Facts

Links? Where??
If Excel says you have links but you can't find them, go to Formulas, Name Manager. Look for old links to dead workbooks & delete.
You must log in or register to reply here.

Forum statistics

Threads
1,223,893
Messages
6,175,240
Members
452,621
Latest member
Laura_PinksBTHFT

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top