I am trying to add to add French version to my code. I have macro that reads from text file report and extracts dates in correct format. Text file date format is JUL13/2023. My macro works just fine but sometimes dates appear in French - JAN - January, F:V – February, MAR - March, AVR - April, MAI- May, JUN - June, JLT - July, AO} – August, SEP – September, OCT – October, NOV - November, D:C – December. I am trying to find the best solution to add it into my code so it can read all possible dates and give me just regular date format as an output. Here is my code:
Sub test()
Dim fn As String, mtch As Object, m As Object, s As Object, txt As String
Dim i As Long
fn = "C:\temp\test.txt"
txt =CreateObject("scripting.filesystemobject").OpenTextFile(fn).ReadAll
With CreateObject("vbscript.regexp")
.Global = True
.Pattern = "[^\n]+"
Set mtch = .Execute(txt)
i = 1
Dim b As Long
b = 1
For Each m In mtch
.Pattern = "[a-zA-Z0-9]{7}\s\s[^\s]+\s[a-zA-Z\s]*[0-9]{2}\/[0-9]{4}"
For Each s In .Execute(m.Value)
i = i + 1
Cells(i, 1) = s
b = b + 1
Range("B" & b).Value = Right(Cells(i, 1), 10)
Next
Next
End With
Dim var As String
Dim N As Long, p As Long, j As Long
N = Cells(Rows.Count, "B").End(xlUp).Row
For p = 2 To N
var = Range("B" & p).Value
Range("C" & p).Value = convert_date(var)
Range("D" & p).Value = Range("C" & p) + 179
Range("E" & p).Value = Range("C" & p) + 209
j = j + 1
Next p
End Sub
Function convert_date(date_as_string As String) As Date
Dim mthstring As String
mthstring = "JAN,FEB,MAR,APR,MAY,JUN,JUL,AUG,SEP,OCT,NOV,DEC"
convert_date = DateSerial( _
CInt(Right(date_as_string, 4)), _
CInt(((InStr(1, mthstring, Left(date_as_string, 3)) - 1) / 4) + 1), _
CInt(Replace(Mid(date_as_string, 4, 2), "/", "")))
End Function
Sub testConvertDate()
Dim var As String
Dim N As Long, i As Long, j As Long
N = Cells(Rows.Count, "B").End(xlUp).Row
Dim m As Integer
For i = 2 To N
'Range("B" & i).Value = Right("A" & i, 10)
var = Range("B" & i).Value
Range("C" & i).Value = convert_date(var)
Range("D" & i).Value = Range("C" & i) + 179
Range("E" & i).Value = Range("C" & i) + 209
j = j + 1
Next i
End Sub
And here is my outcome:
Because of the fact that your French months name enumeration contains strings of 3 or 4 characters, you need to process the string Date in a different way. Please, try the next adapted function. Do not miss to also copy the function returning only numbers (onlyNo):
Function convert_date(date_as_string As String) As Date
Dim mthstring As String, strLeft As String, arrD, dayNo As Long, monthNo As Long, y As Long
mthstring = "JANV,FEVR,MARS,AVRIL,MAI,JUIN,JUIL,AOUT,SEPT,OCT,NOV,DEC"
arrD = Split(mthstring, ",") 'place the string in an array
y = CLng(Split(date_as_string, "/")(1)) 'extract the year
strLeft = Split(date_as_string, "/")(0) 'extract the left string Date split by "/"
dayNo = onlyNo(strLeft) 'extract the day number
monthNo = Application.match(left(strLeft, Len(strLeft) - Len(CStr(dayNo))), arrD, 0) 'extract the month number
convert_date = DateSerial(y, monthNo, dayNo) 'convert to Date
End Function
Private Function onlyNo(strX As String) As Long
With CreateObject("vbscript.regexp")
.Pattern = "[^0-9]" 'replace everything except numbers
.Global = True
onlyNo = CLng(.replace(strX, "")) 'remove all letters
End With
End Function
The function should be called exactly as in your existing code.
You can simple test it using the next testing Sub. Please, uncomment the commented lines one by one and run it:
Sub testConvert_Date()
Dim d As String
d = "MAI31/2022"
'd = "JUIN20/2022"
'd = "NOV4/2022"
Debug.Print convert_date(d)
End Sub
If you need to adapt the function to work, at request, for English days name, too, I can easily adapt the function creating another parameter to select between languages.
Please, send some feedback after testing it.
Option Explicit
Function convert_date(s As String) As Date
Dim ar, arLang(1), regex, v
Dim y As Integer, m As String, d As Integer
arLang(0) = Split("JAN,FEB,MAR,APR,MAY,JUN,JUL,AUG,SEP,OCT,NOV,DEC", ",")
arLang(1) = Split("JANV,FEVR,MARS,AVRIL,MAI,JUIN,JUIL,AOUT,SEPT,OCT,NOV,DEC", ",")
Set regex = CreateObject("vbscript.regexp")
With regex
.Global = False
.MultiLine = False
.Ignorecase = True
.Pattern = "([A-Z]+)(\d{1,2})\/(\d{4})"
End With
If regex.test(s) Then
With regex.Execute(s)(0)
m = .submatches(0)
d = .submatches(1)
y = .submatches(2)
End With
For Each ar In arLang
v = Application.Match(m, ar, 0)
If Not IsError(v) Then
convert_date = DateSerial(y, CInt(v), d)
Exit Function
End If
Next
End If
MsgBox s & " not correct format", vbExclamation
End Function
Related
I am trying to figure out how to get the the total of days in a month like for every monday to saturday or tuesday to sunday then multiply by working hours. It depends on the user if what they like to input in cell. However, the CALCULATION it depends on the date where the user input either in textbox or cell.
For X = 2 To lastRow
val = ThisWorkbook.Sheets("Input").Cells(X, 2).Value
If UCase(val) Like "*TO*" Then
Dim numStringTo As Integer
Dim strToDays() As String
Dim wordToCount As Long
numStringTo = 3
strToDays = VBA.Split(val, " ")
wordToCount = UBound(strToDays)
whEveryDay = ThisWorkbook.Sheets("Input").Cells(X, 4).Value
whEveryDay = whEveryDay * Weekday(nb_days, 6)
Debug.Print "Every = " & whEveryDay
End If
Next X
I need to get the total of days in a month and multiply by working hours. As of now we are in January 2023 and the pattern for January is 2-7,9-14,16-21,23-28,30-31 and the patter for November 2022 is 1-5,8-12,15-19,22-26,29-30.
For example:
Days
Date
Working Hours
every Monday to Saturday
2-7,9-14,16-21,23-28,30-31
1.2
every Tuesday to Saturday
1-5,8-12,15-19,22-26,29-30
0.5
Example of calculation:
Days * Working hours
And I need the calculation dynamically like for example if I change the cell of "every Monday to Saturday" to "every Wednesday to Monday" so, the count of days in a month will be also dynamically.
Thanks in advance,
James
Option Explicit
Sub demo()
Dim lastrow As Long, r As Long, s As String, dt As Date
s = InputBox("Input Date")
If IsDate(s) Then
dt = CDate(s)
Else
MsgBox s & " not a date", vbCritical
Exit Sub
End If
With ThisWorkbook.Sheets("Input")
lastrow = .Cells(.Rows.Count, "B").End(xlUp).Row
For r = 2 To lastrow
s = .Cells(r, "B").Value
If UCase(s) Like "*TO*" Then
' total days in column E
.Cells(r, "E") = mydatecalc(dt, s)
' hrs per day * days
.Cells(r, "F").FormulaR1C1 = "=RC[-2]*RC[-1]"
End If
Next
End With
MsgBox "Calc done for " & Format(dt, "mmm yyyy")
End Sub
Function mydatecalc(dtNow As Date, s As String) As Long
Dim m As Integer, s1 As String, s2 As String, d As String
Dim dt As Date, dtStart As Date, dtEnd As Date
Dim n As Integer, ar, bCount As Boolean, msg As String
m = Month(dtNow) ' input month
dtStart = DateSerial(Year(dtNow), m, 1)
dtEnd = DateAdd("m", 1, dtStart) - 1
ar = Split(s, " ")
s1 = Left(ar(1), 3)
s2 = Left(ar(3), 3)
For dt = dtStart To dtEnd
d = Format(dt, "ddd")
If d = s1 Then bCount = True
If bCount Then
n = n + 1
msg = msg & vbLf & n & " " & Format(dt, "ddd dd")
End If
If d = s2 Then bCount = False
Next
'MsgBox s & " = " & n & " days in " & Format(dtNow, "mmm yyyy") & msg
mydatecalc = n
End Function
You could achieve that with a formula as well (Excel 365) and the following setting:
=LET(monthDays,SEQUENCE(EDATE(A2,1)-A2,1,A2),
weekdays,FILTER(SEQUENCE(1,7),B2:H2<>""),
workingHours,I2,
workedDays,FILTER(monthDays,ISNUMBER(MATCH(WEEKDAY(monthDays,2),weekdays,0))),
COUNT(workedDays)*workingHours)
Please, test the next solution. The range to be processed starts from column B:B and the return will be done in E:E. The code assumes that all strings in B:B contain the necessary data of pattern "every 'day name' to 'day name'":
Sub getHours()
Dim ws As Worksheet, lastR As Long, arr, i As Long, curDate As Date
curDate = Date 'use here your date where from to extract the month
Set ws = ActiveSheet
lastR = ws.Range("B" & ws.rows.count).End(xlUp).Row
arr = ws.Range("B2:E" & lastR).Value2
For i = 1 To UBound(arr)
arr(i, 4) = TotalHoursPerDaysGroup(CStr(arr(i, 1)), curDate, CDbl(arr(i, 3)))
Next i
ws.Range("B2:E" & lastR).Value2 = arr
End Sub
Function TotalHoursPerDaysGroup(val As String, curDay As Date, workingH As Double) As Double
Dim curMonth As Long, startDN As String, endDN As String, nb_days As Long
Dim dtStart As Date, dtEnd As Date, dayN As String, d As Date, arrND, boolCount As Boolean
'Dim arrDaysRo: arrDaysRo = Split("lun.,mar.,mie.,joi,vin.,sâm.,dum.", ",") 'localized days name...
'Dim arrDaysEn: arrDaysEn = Split("Mon,Tue,Wen,Thu,Fry,Sat,Sun", ",")
curMonth = Month(curDay) ' current month
dtStart = DateSerial(Year(curDay), curMonth, 1)
dtEnd = WorksheetFunction.EoMonth(dtStart, 0)
arrND = Split(val, " ")
startDN = left(arrND(1), 3)
endDN = left(arrND(3), 3)
For d = dtStart To dtEnd
dayN = Format(d, "ddd")
If dayN = startDN Then boolCount = True
'If arrDaysEn(Application.match(dayN, arrDaysRo, 0) - 1) = startDN Then boolCount = True
If boolCount Then
nb_days = nb_days + 1
End If
If d = endDN Then boolCount = False
'If arrDaysEn(Application.match(dayN, arrDaysRo, 0) - 1) = endDN Then boolCount = False
Next d
TotalHoursPerDaysGroup = nb_days * workingH
End Function
I tried using first three characters of the days name, but because of localization, I couldn't, so I created two equivalence arrays to overpass the problem. I let them in the function, just in case...
If no such a problem, you can comment the lines making the equivalence and uncomment the ones above them. I can see that my solution used in the function is very similar with the one already posted...
I have a column in "dd-mm-yy hh:mm" format that formed as a result of some action on UserForm:
Dim ws as Worksheet
Set ws = Worksheets("Logs")
With ws
For i = 1 to Me.ListBox1.ListCount - 1
.Cells(lRow + 1 + i, 10).Value = CDate(VBA.Format(Me.ListBox1.List(i), "dd-mm-yy hh:mm"))
Next i
End With
I save the column to Variant variable to use later (to be used multiple times):
Dim arrTimeD As Variant
arrTimeD = Application.Transpose(.Range(TCL & "2:" & TCL & lRow).Value)
The locale date settings are European: "dd-mmm-yyyy"
The spreadsheet are used by different users, some have "dd-mmm" setting, others "mm-dd" etc.
I need to compare the dates in several uses. For, e.g.
Dim bDate as Date
bDate = CDate(VBA.Format(Me.lblCheckin.Caption,"dd-mm-yyyy"))
Do While CDate(arrTimeD(bIndex)) < bDate
If bIndex = lRow - 1 Then Exit Do
bIndex = bIndex + 1
Loop
When the user with US locale ("mm-dd") uses the spreadsheet, CDate(arrTimeD(bIndex)) throws error. CDate(VBA.Format(arrTimeD(bIndex))) and CDate(DateValue(arrTimeD(bIndex)) didn't help. What is the best way to do it?
Is it possible to set workbook's own date setting regardless of OS's?
Or I need to convert variant to string then concatenate?
The date string should be converted into a numeric date value.
Function DDMMYYYFormatToDateTimeValue(DateString As String) As Date
Dim Parts() As String
Parts = Split(DateString, "-")
DDMMYYYFormatToDateTimeValue = CDate(Parts(1) & "/" & Parts(0) & "/" & Parts(2))
End Function
Usage
Private Sub UserForm_Initialize()
Dim n As Long
For n = 1 To 100
ListBox1.AddItem Format(Date + n / 24, "MM-DD-YY HH:MM")
Next
End Sub
Public Function ListBoxDateValues()
Dim Data As Variant
ReDim Data(1 To Me.ListBox1.ListCount, 1 To 1)
Dim DateString As String
Dim r As Long
For r = 1 To Me.ListBox1.ListCount
DateString = Me.ListBox1.List(r - 1)
Data(r, 1) = DDMMYYYFormatToDateTimeValue(DateString)
Next
ListBoxDateValues = Data
End Function
Public Function wsLogs() As Worksheet
Set wsLogs = ThisWorkbook.Sheets("Logs")
End Function
Function DDMMYYYFormatToDateTimeValue(DateString As String) As Date
Dim Parts() As String
Parts = Split(DateString, "-")
DDMMYYYFormatToDateTimeValue = CDate(Parts(1) & "/" & Parts(0) & "/" & Parts(2))
End Function
First, true date values carry no format, so convert your text dates from the listbox directly to true date values:
.Cells(lRow + 1 + i, 10).Value = CDate(Me.ListBox1.List(i))
These you can apply the format you prefer for display.
The comparison is now straight:
Dim bDate As Date
bDate = CDate(Me.lblCheckin.Caption)
Do While arrTimeD(bIndex) < bDate
If bIndex = lRow - 1 Then
Exit Do
Else
bIndex = bIndex + 1
End If
Loop
My code run perfectly but when it comes to add duration more than 24 hours, the code return time of next day. Please see image:
For instance:
CELL(C3)-0500_1145-DURATION IS 6.45
CELL(D3)-CTC-THE CODE WILL IGNORE AND MOVE TO NEXT CELL
CELL(E3)-0500_1145-DURATION IS 6.45
CELL(F3)-0500_1145-DURATION IS 6.45----TOTAL
DURATION=6.45(C3)+6.45(E3)+6.45(F3)=20.15
CELL(G3) & CELL(I3)-OFF -THE CODE WILL IGNORE AND MOVE TO NEXT CELL
CELL(H3)-1000_1800(ACP)-DURATION IS 8
Although the code calculate the duration right here i.e 8 hours but when the system sum all the duration it should give 28:15 but the system is taking it as next day and return total duration as 4:15.
My issue is that how can i make the system to return 28 hours 15 mins(28:15) iso of 4:15 when duration is more than 24 hours.
Sub CalculateHourly()
Dim j As Long
Dim TextTime, wStart, wStop, midnight As String
Dim TrueTime, Temp As Date
Dim Parts As Variant
Dim lRow As Long
Application.Calculation = xlManual
midnight = "24" & ":" & "00"
'Find the last non-blank cell in column A(1)
lRow = Cells(Rows.Count, 1).End(xlUp).Row
For i = 3 To lRow
For j = 3 To 9
TextTime = ""
'copy content of the cells
TextTime = ThisWorkbook.Application.Sheets("Sheet1").Cells(i, j).Value
'loop only of cell does not contain any text
If InStr(1, TextTime, "CTC", vbTextCompare) = 0 And InStr(1, TextTime, "OFF", vbTextCompare) = 0 And InStr(1, TextTime, "LEAVE", vbTextCompare) = 0 _
And Not IsEmpty(TextTime) Then
Parts = Split(TextTime, "_")
'Left(Parts(0), 2) of 0430-04
'Right(Parts(0), 2) of 0430-30
wStart = Left(Parts(0), 2) & ":" & Right(Parts(0), 2)
'wStop = Left(Parts(1), 2) & ":" & Right(Parts(1), 2)
wStop = Left(Parts(1), 2) & ":" & Mid(Parts(1), 3, 2)
Debug.Print ("test : " & Format(wStart, "h:mm;#"))
'If timeout is less than timein
If wStart > wStop Then
'Add 24 hours and make the diff
TrueTime = 24 + CDate(CDate(CDate(Format(wStop, "h:mm;#")) - CDate(Format(wStart, "h:mm;#"))))
Else
'if timeout greater than timein
TrueTime = CDate(CDate(CDate(Format(wStop, "h:mm;#")) - CDate(Format(wStart, "h:mm;#"))))
End If
**If (Temp + TrueTime) > 24 Then
TrueTime = 24 + Temp + TrueTime**
Else
TrueTime = Temp + TrueTime
End If
Temp = TrueTime
End If
Next j 'move to the number column in the same row
Cells(i, 10).Value = CDate(Format(Temp, "h:mm;#"))
Temp = Temp - Temp
Next i 'move to the next row
End Sub
Use a function like this to format to hours:minutes only:
Public Function FormatHourMinute( _
ByVal datTime As Date, _
Optional ByVal strSeparator As String = ":") _
As String
' Returns count of days, hours and minutes of datTime
' converted to hours and minutes as a formatted string
' with an optional choice of time separator.
'
' Example:
' datTime: #10:03# + #20:01#
' returns: 30:04
'
' 2005-02-05. Cactus Data ApS, CPH.
Dim strHour As String
Dim strMinute As String
Dim strHourMinute As String
strHour = CStr(Fix(datTime) * 24 + Hour(datTime))
' Add leading zero to minute count when needed.
strMinute = Right("0" & CStr(Minute(datTime)), 2)
strHourMinute = strHour & strSeparator & strMinute
FormatHourMinute = strHourMinute
End Function
Sub CalculateHourly2()
Dim j As Long
Dim TextTime As String, wStart As Date, wStop As Date, midnight As String
Dim Parts As Variant
Dim lRow As Long
Dim vArray() As Variant, n As Integer
Application.Calculation = xlManual
'Find the last non-blank cell in column A(1)
lRow = Cells(Rows.Count, 1).End(xlUp).Row
For i = 3 To lRow
n = 0
For j = 3 To 9
TextTime = ""
'copy content of the cells
TextTime = ThisWorkbook.Application.Sheets("Sheet1").Cells(i, j).Value
'loop only of cell does not contain any text
If InStr(1, TextTime, "CTC", vbTextCompare) = 0 And InStr(1, TextTime, "OFF", vbTextCompare) = 0 And InStr(1, TextTime, "LEAVE", vbTextCompare) = 0 _
And TextTime <> "" Then '<~~ Unlike the case where the cell is empty, if you put an empty cell into a variable, it is not empty.
Parts = Split(TextTime, "_")
'Left(Parts(0), 2) of 0430-04
'Right(Parts(0), 2) of 0430-30
wStart = TimeValue(Left(Parts(0), 2) & ":" & Right(Parts(0), 2))
'wStop = TimeValue(Left(Parts(1), 2) & ":" & Right(Parts(1), 2))
wStop = Left(Parts(1), 2) & ":" & Mid(Parts(1), 3, 2) '<~~ Since other characters have been added, the mid sentence must be used.
n = n + 2
ReDim Preserve vArray(1 To n)
vArray(n - 1) = wStart
vArray(n) = wStop
End If
Next j 'move to the number column in the same row
'Cells(i, 10).Value = CDate(Format(Temp, "h:mm;#"))
If n > 0 Then
Cells(i, 10).Value = getTime(vArray)
Cells(i, 10).NumberFormat = "[hh]:mm"
End If
Next i 'move to the next row
End Sub
Function getTime(Other() As Variant)
Dim myTime As Date, s As Date, e As Date
Dim i As Integer
For i = LBound(Other) To UBound(Other) Step 2
s = Other(i)
e = Other(i + 1)
If s > e Then
e = e + 1
End If
myTime = myTime + e - s
Next i
getTime = myTime
End Function
Sheet Image
If I have values in cell c3= 2,4,6,8,12,14,18,23,35,78,101,38,30,205,2,101
In This two values are duplicate which is { 2,101 }
I want notification as and when enter any value twice, three-time , forth time, etc in that cell i should come to know which value is repeated. Duplicate values can be shown in adjacent cell D3,
Try this
Sub Test_CheckDups_UDF()
With Range("A1")
.Value = "2,4,6,8,12,14,18,23,35,78,101,38,30,205,2,101"
.Offset(, 1).Value = CheckDups(.Value)
End With
End Sub
Function CheckDups(s As String) As String
Dim a, dic As Object, i As Long
Set dic = CreateObject("scripting.dictionary")
a = Split(s, ",")
For i = LBound(a) To UBound(a)
If dic.Exists(a(i)) = True Then CheckDups = CheckDups & IIf(CheckDups = Empty, "", ",") & a(i) Else dic.Add a(i), 1
Next i
End Function
Here's a code that will highlight the duplicates within the same cell. Tweak it so as to suit your needs
Sub Highlight_Duplicates_Within_Cell()
Dim s, sp, k, c As Range, t As String, f As Boolean, n As Long
For Each c In Range("C3:C13")
c.Font.Color = vbBlack
With CreateObject("Scripting.Dictionary")
.CompareMode = vbTextCompare
sp = Split(c.Value, ",")
For Each s In sp
If Not .Exists(s) Then .Add s, 1 Else .Item(s) = .Item(s) + 1
Next s
For Each k In .Keys
t = "," & k & ","
f = False
n = InStr(1, "," & c.Value & ",", t, vbTextCompare)
Do While n And .Item(k) > 1
If f Then
c.Characters(n, Len(t) - 2).Font.Color = vbRed
End If
n = InStr(n + Len(k), "," & c.Value & ",", t, vbTextCompare)
f = True
Loop
Next k
End With
Next c
End Sub
Try this version too using Regex
Sub Highlight_Duplicates2()
Dim mtch As Object, mtch2 As Object, m As Object, mm As Object, c As Range, txt As String, i As Long
For Each c In Range("C3:C13")
With CreateObject("VBScript.RegExp")
.Global = True
txt = c.Value
.Pattern = " *(\w+)"
Set mtch = .Execute(txt)
For Each m In mtch
.Pattern = "\b" & m.submatches(0) & "\b"
Set mtch2 = .Execute(txt)
If mtch2.Count > 1 Then
For i = 1 To .Execute(txt).Count - 1
Set mm = mtch2(i)
With c.Characters(mm.firstindex + 1, mm.length).Font
.Color = vbRed: .Bold = True
End With
Mid$(txt, mm.firstindex + 1, mm.length) = Space(mm.length)
Next i
End If
Next m
End With
Next c
End Sub
This does not meet your request of trapping duplicates while typing. However to process a comma-separated string (once entered) consider the following user defined function:
Public Function duplist(s As String) As String
Dim s2 As String, arr
Dim kount As Long, i As Long, j As Long
arr = Split(s, ",")
For i = 0 To UBound(arr)
kount = 0
v = arr(i)
For j = 0 To i
If v = arr(j) Then kount = kount + 1
Next j
If kount = 2 Then s2 = s2 & "," & v
Next i
duplist = Mid(s2, 2)
End Function
I'm trying to compared 2 different excel files that contain same fields sometimes.
When I find it (by watch view) the vba say they are different...
Dim ctrl As Integer
Sub btnCheck_Click()
Dim lot As Workbook, pr As Workbook, this As Workbook
Dim a As Variant, b As Variant
Dim i As Integer, j As Integer
Dim passed As Boolean
Set this = Application.ThisWorkbook
this.Worksheets(1).Range("C5:J1000").ClearContents
Application.ScreenUpdating = False
a = ThisWorkbook.Path & "\" & "A.xlsx"
Set lot = Application.Workbooks.Open(a, False, False)
b = ThisWorkbook.Path & "\" & "B.xls"
Set pr = Application.Workbooks.Open(b, False, False)
i = 2
x = 2
lin = 2
Do Until lot.Worksheets(1).Range("A" & i).Value = ""
passed = False
j = 2
Do Until pr.Worksheets(1).Range("A" & j).Value = ""
If lot.Worksheets(1).Range("B" & i).Value = pr.Worksheets(1).Range("C" & j).Value Then
passed = True
this.Worksheets(1).Range("D" & x).Value = "ok"
x = x + 2
End If
j = j + 1
Loop
i = i + 1
Loop
lot.Close True
Set lot = Nothing
pr.Close True
Set pr = Nothing
Application.ScreenUpdating = True
End Sub
Function CleanStr(ByVal str As String)
CleanStr = Replace(str, Chr$(32), "")
End Function
The files A and B are linked at the comments bellow.
A and B are not the same. One ends in a space (ASCII 32) while the other ends in a non-breaking space (ASCII 160). Invisible is invisible to our eyes, but to a computer, ASCII(32)<>ASCII(160)
You can verify this by adding this function to your macro:
Function strings2ascii(ByVal str1 As String, str2 As String)
Dim x As Integer
Dim intStrLen As Integer
Dim strResult As String
If Len(str1) > Len(str2) Then
intStrLen = Len(str1)
Else
intStrLen = Len(str2)
End If
For x = 1 To Len(str1)
strResult = strResult & Asc(Mid(str1, x, 1)) & ":" & Asc(Mid(str2, x, 1)) & vbCrLf
Next
MsgBox strResult
End Function
Now call this function in your loop:
Do Until pr.Worksheets(1).Range("A" & j).Value = ""
strings2ascii lot.Worksheets(1).Range("B" & i).Value, pr.Worksheets(1).Range("C" & j).Value
If lot.Worksheets(1).Range("B" & i).Value = pr.Worksheets(1).Range("C" & j).Value Then
You will immediately see that they never match because they are not the same. Here is a similar SO post regarding ASCII 160 errors: Trouble replacing Chr(160) with VBA in excel
Not sure if this will answer the question but that can't stand in a comment :)
I would say that some cells contains invisible chars that arent spaces.
Here's a recursive function that remove them from a string :
Function CleanString(StrIn As String) As String
' "Cleans" a string by removing embedded control (non-printable)
' characters, including carriage returns and linefeeds.
' Does not remove special characters like symbols, international
' characters, etc. This function runs recursively, each call
' removing one embedded character
Dim iCh As Integer
CleanString = StrIn
For iCh = 1 To Len(StrIn)
If Asc(Mid(StrIn, iCh, 1)) < 32 Then
'remove special character
CleanString = Left(StrIn, iCh - 1) & CleanString(Mid(StrIn, iCh + 1))
Exit Function
End If
Next iCh
End Function
Give it a try like this :
Do Until b.Worksheets(1).Range("A" & j).Value = ""
sa = CleanString(a.Worksheets(1).Range("B" & i).Value)
sb = CleanString(b.Worksheets(1).Range("C" & j).Value)
oa = CleanString(a.Worksheets(1).Range("E" & i).Value)
ob = CleanString(b.Worksheets(1).Range("F" & j).Value)
If StrComp(sa, sb) = 0 And StrComp(oa, ob) = 0 Then
Passed = True