Forum Discussion

Georgetimes's avatar
Georgetimes
Frequent Visitor
1 year ago

calculate difference between two separate filtered measure

Hi,   I'm having some issues solving this. I've tried multiple way, none with success.   It's hard to provide you with a data sample, but my tables are as per below: Main Data - columns that mat...
Need Help
Georgetimes's avatar
Georgetimes
Frequent Visitor
1 year ago

Sub ExtractAndProperForename()
Dim wsSource As Worksheet
Dim wsTarget As Worksheet
Dim lastRow As Long
Dim header As Range
Dim columnHeaders As Variant
Dim columnsDict As Object
Dim i As Long
Dim forenameColumn As Long
Dim forenameValue As String

' Create a dictionary to hold column headers and their respective column numbers
Set columnsDict = CreateObject("Scripting.Dictionary")

' Define the headers you are looking for
columnHeaders = Array("Forename", "Surname", "Country", "DOB", "Email", "Phone") ' Add more headers if needed

' Reference to the source sheet (adjust if your sheet name is different)
Set wsSource = ThisWorkbook.Sheets("Sheet1")

' Create or reference a target sheet (e.g., "FormattedData")
On Error Resume Next ' In case the sheet doesn't exist
Set wsTarget = ThisWorkbook.Sheets("FormattedData")
On Error GoTo 0 ' Reset error handling

If wsTarget Is Nothing Then
' If "FormattedData" sheet doesn't exist, create it
Set wsTarget = ThisWorkbook.Sheets.Add
wsTarget.Name = "FormattedData"
End If

' Get the last row of data in the sheet
lastRow = wsSource.Cells(wsSource.Rows.Count, "A").End(xlUp).Row

' Loop through the first row (header row) to find column numbers for each required header
For Each header In wsSource.Rows(1).Cells
headerName = header.Value
' If the header matches any in the columnHeaders array, add the column number to the dictionary
If Not IsError(Application.Match(headerName, columnHeaders, 0)) Then
columnNumber = header.Column
columnsDict.Add headerName, columnNumber
End If
Next header

' If the dictionary has columns, process each row and extract the data
If columnsDict.Count > 0 Then
' Loop through each row and extract the corresponding data
For i = 2 To lastRow
' Extract Forename value using the dynamically found column
If columnsDict.Exists("Forename") Then
forenameColumn = columnsDict("Forename")
forenameValue = Application.WorksheetFunction.Proper(wsSource.Cells(i, forenameColumn).Value)

' You can now move the Forename to the target sheet
wsTarget.Cells(i, 1).Value = forenameValue ' Move Forename to column A
End If
Next i
Else
MsgBox "No required columns found!", vbExclamation
End If
End Sub

  • FlowerPower's avatar
    FlowerPower
    New Member
    7 months ago

    Sub TransformCustomerData()

        Dim wsSrc As Worksheet, wsDest As Worksheet

        Dim lastRow As Long, lastCol As Long

        Dim colMap As Object: Set colMap = CreateObject("Scripting.Dictionary")

        Dim i As Long, destRow As Long

       

        'Set source worksheet

        Set wssrc=ThisWorkbook.Sheets("Sheet1")

        lastRow = wsSrc.Cells(wsSrc.Rows.Count, 1).End(xlUp).Row

        lastCol = wsSrc.Cells(1, wsSrc.Columns.Count).End(xlToLeft).Column

       

        'Map Headers

        For i = 1 To lastCol

            If Trim(wsSrc.Cells(1, i).Value) <> "" Then

               colMap(Trim(wsSrc.Cells(1, i).Value)) = i

            End If

        Next i

       

        'Create destination sheet

        On Error Resume Next: Application.DisplayAlerts = False

        ThisWorkbook.Sheets("Transformed Data").Delete

        Application.DisplayAlerts = True: On Error GoTo 0

       

        Set wsDest = ThisWorkbook.Sheets.Add(After:=wsSrc)

        If wsDest Is Nothing Then

           MsgBox "Failed to create destination sheet. Aborting."

           Exit Sub

          End If

        wsDest.Name = "Transformed Data"

       

        'Output headers

        Dim outHeaders As Variant

        outHeaders = Array("Customer Reference", "Full Name", "Date of birth", "Building number", "Premise", "Street", "City", "Postcode", "Country", "Email", "Landline", "Mobile", _

                           "AuthenticationID", "Date", "Band Text", "Synthetic ID Score", "Email Fraud Type", "Email Fraud Risk Level", "Email First Seen", "Email Searches", _

                           "Email Domain Seen First Time", "SIM Swap", "Call Forwarding")

        For i = 0 To UBound(outHeaders)

            wsDest.Cells(1, i + 1).Value = outHeaders(i)

        Next i

       

        'Setup code maps

        Dim fraudMap As Object: Set fraudMap = CreateObject("Scripting.Dictionary")

        fraudMap("4089520") = "Card Not Present Fraud"

        fraudMap("4089521") = "Chargeback"

        fraudMap("4089522") = "First Party Fraud"

        fraudMap("4089523") = "First Payment Default"

        fraudMap("4089524") = "Identity Theft"

        fraudMap("4089525") = "Suspected Fraud"

        fraudMap("4089526") = "Synthetic ID"

        fraudMap("4089527") = "Suspected Synthetic ID"

        fraudMap("4089528") = "Fraud Type Not Available"

      

        Dim riskMap As Object: Set riskMap = CreateObject("Scripting.Dictionary")

        riskMap("4083510") = "Very Low"

        riskMap("4083511") = "Low"

        riskMap("4083512") = "Moderate"

        riskMap("4083513") = "Review"

        riskMap("4083514") = "High"

        riskMap("4083515") = "Very High"

        riskMap("4083600") = "No Risk Flags Hit"

       

        Dim firstSeenMap As Object: Set firstSeenMap = CreateObject("Scripting.Dictionary")

        firstSeenMap("4083400") = "Today"

        firstSeenMap("4083401") = "1-7 Days Ago"

        firstSeenMap("4083402") = "1-2 Weeks Ago"

        firstSeenMap("4083403") = "2-4 Weeks Ago"

        firstSeenMap("4083404") = "1-3 Months Ago"

        firstSeenMap("4083405") = "3-6 Months Ago"

        firstSeenMap("4083406") = "6-12 Months Ago"

        firstSeenMap("4083407") = "1-3 Years Ago"

        firstSeenMap("4083408") = "3-5 Years Ago"

        firstSeenMap("4083409") = "5+ Years Ago"

       

        Dim searchMap As Object: Set searchMap = CreateObject("Scripting.Dictionary")

        searchMap("4083410") = "1 time in last 7 days"

        searchMap("4083411") = "2-4 times in last 7 days"

        searchMap("4083412") = "5-9 times in last 7 days"

        searchMap("4083413") = "10+ times in last 7 days"

       

        Dim domainSeenMap As Object: Set domainSeenMap = CreateObject("Scripting.Dictionary")

        domainSeenMap("4083200") = "less than 6 months ago"

        domainSeenMap("4083201") = "6-12 months ago"

        domainSeenMap("4083202") = "1-3 years ago"

        domainSeenMap("4083203") = "3-5 years ago"

        domainSeenMap("4083204") = "5+ years ago"

       

        Dim simSwapMap As Object: Set simSwapMap = CreateObject("Scripting.Dictionary")

        simSwapMap("5176504") = "SIMSwap 24hrs"

        simSwapMap("5176505") = "SIMSwap 48hrs"

        simSwapMap("5176506") = "SIMSwap 7 days"

        simSwapMap("5176507") = "SIMSwap 30 days"

        simSwapMap("5176508") = "SIMSwap 60 days"

        simSwapMap("5176509") = "SIMSwap 90 days"

        simSwapMap("5176510") = "SIMSwap 180 days"

        simSwapMap("5176511") = "SIMSwap 365 days"

        simSwapMap("5176512") = "SIMSwap over 365 days"

       

        'Loop rows

        destRow = 2

        For i = 2 To lastRow

            With wsDest

                 .Cells(destRow, 1).Value = wsSrc.Cells(i, colMap("Customer Reference"))

                

                  Dim fname As String, mname As String, sname As String

                  fname = ProperName(wsSrc.Cells(i, colMap("Forename")).Value)

                  mname = ProperName(wsSrc.Cells(i, colMap("Middle Name")).Value)

                  sname = ProperName(wsSrc.Cells(i, colMap("Surname")).Value)

                  .Cells(destRow, 2).Value = BuildFullName(fname, mname, sname)

     

       

                  Dim dd, mm, yyyy

                  dd = wsSrc.Cells(i, colMap("Day of Birth")).Value

                  mm = wsSrc.Cells(i, colMap("Month of Birth")).Value

                  yyyy = wsSrc.Cells(i, colMap("Year of Birth")).Value

                  If IsNumeric(dd) And IsNumeric(mm) And IsNumeric(yyyy) Then

                  If dd >= 1 And dd <= 31 And mm >= 1 And mm <= 12 And yyyy >= 1900 Then

                     .Cells(destRow, 3).Value = DateSerial(yyyy, mm, dd)

                     .Cells(destRow, 3).NumberFormat = "dd/mm/yyyy"

                  End If

                End If

       

                  Dim line1, line2

                  line1 = Trim(wsSrc.Cells(i, colMap("Current Address Building")).Value)

                  line2 = Trim(wsSrc.Cells(i, colMap("Current Address Premise")).Value)

                  .Cells(destRow, 4).Value = ProperName(IIf(line1 <> "", line1, line2))

                  .Cells(destRow, 5).Value = ProperName(wsSrc.Cells(i, colMap("Current Address Premise")).Value)

                  .Cells(destRow, 6).Value = ProperName(wsSrc.Cells(i, colMap("Current Address Street")).Value)

                  .Cells(destRow, 7).Value = ProperName(wsSrc.Cells(i, colMap("Current Address City")).Value)

                  .Cells(destRow, 8).Value = wsSrc.Cells(i, colMap("Current Address Zip/Postcode")).Value

        

                  .Cells(destRow, 9).Value = wsSrc.Cells(i, colMap("Current Address Country")).Value

                  .Cells(destRow, 10).Value = wsSrc.Cells(i, colMap("Email")).Value

                  .Cells(destRow, 11).Value = wsSrc.Cells(i, colMap("Land Telephone Number")).Value

                  .Cells(destRow, 12).Value = wsSrc.Cells(i, colMap("Mobile Telephone Number")).Value

                  .Cells(destRow, 13).Value = wsSrc.Cells(i, colMap("Authentication ID")).Value

                  .Cells(destRow, 14).Value = wsSrc.Cells(i, colMap("Timestamp")).Value

                  .Cells(destRow, 15).Value = wsSrc.Cells(i, colMap("Band Text")).Value

                  .Cells(destRow, 16).Value = wsSrc.Cells(i, colMap("Synthetic ID Score")).Value

       

                  Dim j As Long, checkCode As String

                  Dim fraudVal As String: fraudVal = "False"

                  Dim riskVal As String: riskVal = "False"

                  Dim firstSeenVal As String: firstSeenVal = "False"

                  Dim searchVal As String: searchVal = "False"

                  Dim domainSeenVal As String: domainSeenVal = "False"

                  Dim simSwapVal As String: simSwapVal = "False"

                  Dim callForwardingVal As String: callForwardingVal = "False"

       

                  For j = wsSrc.Range("IZ1").Column To wsSrc.Range("ABC1").Column

                      checkCode = Trim(wsSrc.Cells(i, j).Text)

                      If fraudVal = "False" And fraudMap.exists(checkCode) Then fraudVal = fraudMap(checkCode)

                      If riskVal = "False" And riskMap.exists(checkCode) Then riskVal = riskMap(checkCode)

                      If firstSeenVal = "False" And firstSeenMap.exists(checkCode) Then firstSeenVal = firstSeenMap(checkCode)

                      If searchVal = "False" And searchMap.exists(checkCode) Then searchVal = searchMap(checkCode)

                      If domainSeenVal = "False" And domainSeenMap.exists(checkCode) Then domainSeenVal = domainSeenMap(checkCode)

                      If simSwapVal = "False" And simSwapMap.exists(checkCode) Then simSwapVal = simSwapMap(checkCode)

                      If callForwardingVal = "False" And checkCode = "5176600" Then callForwardingVal = "True"

                 Next j

       

                 .Cells(destRow, 17).Value = fraudVal

                 .Cells(destRow, 18).Value = riskVal

                 .Cells(destRow, 19).Value = firstSeenVal

                 .Cells(destRow, 20).Value = searchVal

                 .Cells(destRow, 21).Value = domainSeenVal

                 .Cells(destRow, 22).Value = simSwapVal

                 .Cells(destRow, 23).Value = callForwardingVal

             End With

             destRow = destRow + 1

         Next i

     

         MsgBox "Data transformation complete!"

     End Sub

     

     

    Function ProperName(ByVal str As String) As String

       Dim x As Variant, i As Integer

       str = Application.WorksheetFunction.Trim(str)

       x = Split(LCase(str))

       For i = 0 To UBound(x)

           If Len(x(i)) > 0 Then

               x(i) = UCase(Left(x(i), 1)) & Mid(x(i), 2)

           End If

        Next i

        ProperName = Join(x, " ")

    End Function

     

    Function BuildFullName(fname As String, mname As String, sname As String) As String

         Dim parts As Collection

         Set parts = New Collection

         If Len(Trim(fname)) > 0 Then parts.Add Trim(fname)

         If Len(Trim(mname)) > 0 Then parts.Add Trim(mname)

         If Len(Trim(sname)) > 0 Then parts.Add Trim(sname)

        

         Dim fullName As String, part As Variant

         For Each part In parts

             fullName = fullName & part & " "

         Next part

        

         BuildFullName = Application.WorksheetFunction.Trim(fullName)

    End Function