Selected Answer
Fida
Attached are two files. The second file is like the portal data (only) in your Question test file but:
- column B had values like AB-ABC-XYZ90276-1 but the physical ones missed that Z e.g. XY90276 - that's still the case in yellow cell c3 but I corrected them elsewhere
- yellow cell C5 added an initial missing ";" delimiter so AB-ABC-XYZ90070-1; AB-ABC-XYZ90070-2;....
- the data connection is removed.
Please save that file and close. Then open the first file "Parse EV charger data v0_a.xlsm" (with macros enabled), click the blue button labelled "Parse data from file" and follow the prompts to open the second file (or other files like that).
You should end up with a new file with the second sheet as a copy of the portal data used (as evidence) and the first sheet showing the parsed data in a table. Any yellow cells are where a match wasn't seen (between B and C values). In the case of the second file, that's from the C3 errors I left in.deliberately
The work is done by the code behind that button (shown below, with comments to explain what's happening broadly). You may need to change the values in the bold lines near the start of the code:
Option Explicit
Option Base 1
Sub ParseButton_Click()
Dim Dlg As Office.FileDialog
Dim ImpStr As String, ImpFile As Workbook, ImpSheet As Worksheet
Dim Strt As Range, Prfx As String, ValDelim As String
Dim Rw As Long, LstRw As Long, OutRw As Long, ArrRw As Long
Dim IdArray As Variant, PhysArray As Variant, PhysRw As Long, PhysSuffSep As String, PossID As String
Dim OutFl As Workbook
On Error Resume Next
' define the delimiter between values
ValDelim = ";"
' define the Prefix string to be removed from EV Spot Src IDs
Prfx = "AB-ABC-"
' define the Suffix separator to be removed from EV Spot Src IDs
PhysSuffSep = "-"
' get the data file to parse
Set Dlg = Application.FileDialog(msoFileDialogFilePicker)
With Dlg
.Filters.Clear
.Filters.Add "Excel Files", "*.xlsx", 1
.Title = "Pick a single Excel file to parse data from"
.AllowMultiSelect = False
' optional- set a path to look for files (and uncomment); should end in \
'.InitialFileName = "C:\"
If .Show = True Then
'get the file name
ImpStr = .SelectedItems(1)
' or tell user none selected...
Else
MsgBox "No file selected- please try again."
Exit Sub
End If
End With
' open file
Workbooks.Open Filename:=ImpStr
' open selected file
Set ImpFile = ActiveWorkbook
Set Strt = Application.InputBox(Prompt:="Click on a cell in the data table", _
Title:="Please select sheet with EV data table and...", Type:=8)
If Strt Is Nothing Then
MsgBox "No cell selected, Parse cancelled"
Exit Sub
Else
' speed up
Application.ScreenUpdating = False
' create new output file
With Workbooks.Add
.Sheets(1).Name = "Parsed data"
With .Sheets.Add(After:=.Sheets(1))
.Name = "Portal data used"
'copy data to this sheet and fit columns
Strt.CurrentRegion.Copy
.Cells(1, 1).PasteSpecial xlPasteAll
.Cells(1, 1).CurrentRegion.Columns.AutoFit
'find last row
LstRw = .Cells(Rows.Count, 1).End(xlUp).Row
.Cells(2, 5).Select
' add header row to Parsed data sheet
.Parent.Sheets(1).Range("A1:C1").Value = _
Array("Charging station name", _
"Charging spot SRC ID)", _
"Charging spot physical reference")
OutRw = 2
' loop down sheet
For Rw = 2 To LstRw
'split columns A & B values into arrays
IdArray = Split(.Cells(Rw, 2), ValDelim)
PhysArray = Split(.Cells(Rw, 3), ValDelim)
' loop though column B parsed values
For ArrRw = LBound(IdArray, 1) To UBound(IdArray, 1)
' write values in columns A & B
.Parent.Sheets(1).Cells(OutRw, 1).Value = Trim(.Cells(Rw, 1))
.Parent.Sheets(1).Cells(OutRw, 2).Value = Trim(IdArray(ArrRw))
' set error message in C
.Parent.Sheets(1).Cells(OutRw, 3).Value = "Not matched in " & Trim(.Cells(Rw, 3))
.Parent.Sheets(1).Cells(OutRw, 3).Interior.Color = vbYellow
For PhysRw = LBound(PhysArray, 1) To UBound(PhysArray, 1)
' refine a string from B to create possible ID (physical)
PossID = Trim(Replace(IdArray(ArrRw), Prfx, ""))
PossID = Trim(Left(PossID, InStrRev(PossID, PhysSuffSep) - 1))
' check if there's a matching physical ID
If Trim(PhysArray(PhysRw)) = PossID Then
' if so, replace error message with value and stop looking
.Parent.Sheets(1).Cells(OutRw, 3).Value = Trim(PhysArray(PhysRw))
.Parent.Sheets(1).Cells(OutRw, 3).Interior.Color = vbWhite
Exit For
End If
Next PhysRw
' increment row number for output values
OutRw = OutRw + 1
Next ArrRw
Next Rw
With .Parent.Sheets(1)
'fit columns
.UsedRange.Columns.AutoFit
' convert to table (and name) then show results
.ListObjects.Add(xlSrcRange, .UsedRange, , xlYes).Name = "EVtable"
' add details of extract in new row 1
.Rows(1).Insert
.Cells(1, 1).Value = "Data parsed from file( - sheet): " _
& ImpStr & " - " & Strt.Worksheet.Name
' close file
ImpFile.Close SaveChanges:=False
.Activate
.Cells(2, 5).Select
End With
End With
End With
End If
Application.ScreenUpdating = True
' tell user
MsgBox "Done! Please click OK then save file..." & vbCr & vbCr & "(Any error messages have a yellow fill; " _
& vbCr & "source data captured on second sheet)", vbOKOnly, "Data parsed"
' prompt save
Set Dlg = Application.FileDialog(msoFileDialogSaveAs)
With Dlg
' suggest name (including date)
.InitialFileName = "EV IDs Parsed data " & Format(Date, "dd-mmm-yyyy") & ".xlsx"
.Title = "Save file (and change file name if needed)"
If .Show = True Then .Execute
End With
End Sub
Hope this is what you want (I've spend too much time creating it!). If so please mark this Answer as Selected.
