Subtract a textbox value from a cell - excel

I have an inventory sheet.
When a researcher takes a quantity in a specific lot, the quantity is removed first from the stock quantity, the specific row of ComboBox1 in the column #8. It's okay for that part.
When a second quantity is taken and the row of the lot is not empty, I put the data in a row under but I want the quantity (textBox2) to be substract to the column #8 of the row of ComboBox1.
Private Sub CommandButton1_Enter()
Dim emptyRow As Long
Dim ws As Worksheet
Set ws = ActiveSheet
ActiveSheet.Name = "Micrux"
Dim iLastRow As Long, iFound As Long
Dim rng, bEmpty As Boolean, c As Integer
Dim Test As Boolean
bEmpty = True
With ws
iLastRow = .Range("A" & .Rows.Count).End(xlUp).Row
Set rng = .Range("A1:A" & iLastRow + 1).Find(ComboBox1.Value, _
After:=.Range("A" & iLastRow + 1), _
LookIn:=xlValues, _
lookat:=xlWhole, _
searchorder:=xlByRows, _
SearchDirection:=xlPrevious)
Test = (TextBox2.Text) > ws.Cells(iLastRow, 8)
If Test = True Then
MsgBox "Not enough quantity in stock!"
Else
If rng Is Nothing Then
iFound = iLastRow + 1
Else
iFound = rng.Row
For c = 4 To 7
If Len(.Cells(iFound, c)) > 0 Then bEmpty = False
Next
If bEmpty = False Then
iFound = iFound + 1
.Cells(iFound, 1).EntireRow.Insert xlShiftDown
.Cells(iFound, 7).Value = TextBox2.Text
.Cells(iFound, 6).Value = TextBox3.Text
.Cells(iFound, 5).Value = ComboBox2.Value
.Cells(iFound, 4).Value = TextBox1.Text
Else
.Cells(iFound, 7).Value = TextBox2.Text
.Cells(iFound, 6).Value = TextBox3.Text
.Cells(iFound, 5).Value = ComboBox2.Value
.Cells(iFound, 4).Value = TextBox1.Text
End If
End If
End If
End With
Unload Me
End Sub

Related

For Each loop on filtered data returning 0 results, no errors

I need to generate a sheet of values out of a database between dates that the user selects. The date is in column 2 of the database, but I need the whole row for every date in this range. I got some advice to use a For Each instead to more easily use the SpecialCells(xlCellTypeVisible). While I am no longer getting any errors I also get no data in my product worksheet. Could someone tell me why I am not returning data?
Sub Generate()
Dim g As Integer
Dim h As Integer
Dim datemin As String
Dim datemax As String
datemin = CDbl(CDate(Sheets("start").Cells(15, 8)))
datemax = CDbl(CDate(Sheets("start").Cells(15, 9)))
Worksheets("Database").Range("A1").AutoFilter Field:=10, Criteria1:=">=" & datemin, _
Operator:=xlAnd, Criteria2:="<=" & datemax
g = 0
For Each Row In Worksheets("database").Range("A1")
g = g + 1
If Cells(g, 1).SpecialCells(xlCellTypeVisible) = True And Cells(g, 1) <> "" Then
Sheets("product").Activate
Dim NextRow As Long
NextRow = Application.WorksheetFunction.CountA(Range("A:A")) + 10
'fill KPI
Cells(NextRow, 1) = Format(Sheets("database").Cells(g, 1), "mm/dd/yyyy") 'Date1
Cells(NextRow, 2) = Format(Sheets("database").Cells(g, 2), "mm/dd/yyyy") 'Date2
Cells(NextRow, 3) = Sheets("database").Cells(g, 3) 'value1
Cells(NextRow, 4) = Sheets("database").Cells(g, 4) 'value2
Cells(NextRow, 6) = Sheets("database").Cells(g, 5) 'value3
Cells(NextRow, 9) = Sheets("database").Cells(g, 8) 'comment
Cells(NextRow, 13) = Sheets("database").Cells(g, 6) 'person
Else
Exit For
End If
Next
End Sub
You are only 'looping' through one cell - A1.
If you want to use a loop for this try looping through all the rows on the database and checking if they are visible or not.
If they are visible then copy the relevant data to the other sheet.
Sub Generate()
Dim rngDst As Range
Dim rngSrc As Range
Dim datemin As String
Dim datemax As String
Dim g As Integer
Dim h As Integer
datemin = CDbl(CDate(Sheets("start").Cells(15, 8)))
datemax = CDbl(CDate(Sheets("start").Cells(15, 9)))
Worksheets("Database").Range("A1").AutoFilter Field:=10, Criteria1:=">=" & datemin, _
Operator:=xlAnd, Criteria2:="<=" & datemax
Set rngSrc = Worksheets("Database").Range("A2")
Set rngDst = Worksheets("Product").Range("A11")
Do
If Not rngSrc.EntireRow.Hidden And rngSrc.Value <> "" Then
'fill KPI
rngDst.Value = Format(rngSrc.Value, "mm/dd/yyyy") 'Date1
rngDst.Offset(, 1).Value = Format(rngSrc.Offset(, 1).Value, "mm/dd/yyyy") 'Date2
rngDst.Offset(, 2).Value = rngSrc.Offset(, 2).Value 'value1
rngDst.Offset(, 3).Value = rngSrc.Offset(, 3).Value 'value2
rngDst.Offset(, 5).Value = rngSrc.Offset(, 4).Value 'value3
rngDst.Offset(, 8).Value = rngSrc.Offset(, 7).Value 'comment
rngDst.Offset(, 12).Value = rngSrc.Offset(, 5).Value 'person
Set rngDst = rngDst.Offset(1, 0)
End If
Set rngSrc = rngSrc.Offset(1, 0)
Loop Until rngSrc = ""
End Sub

VBA value range doing strange

So how do i put this i am a vba rookie and i have been trying to make an excel file and the purpose is that it should be an inventory of all items one sheet is for putting items in and other is for giving them away. But that is not the problem, the thing is i wanted to have a page called "databaseinventory" where all products that are taken out are writen down but my value is doing strange. (look at the image)
So this is the input screen and if i type this
this is the output on a different sheet but i don't want it to be 0
I noticed if i change the input and add 3 rows it works but that prevents me of typing more then one product
this is the output that i want to have and i really don't know what is wrong with the code
Sub Btn_Clickweggegeven()
Dim x As Long
Dim Givenaway As Worksheet
Dim Inventory As Worksheet
Dim productn As String
Dim erow As Long
Dim rng As Range
Dim rownumber As Long
Dim row As Long
Dim wsData As Worksheet
Dim wsIn As Worksheet
Dim nextRow As Long
Dim BtnText As String
Dim BtnNum As Long
Dim strName As String
x = 2
Do While Cells(x, 1) <> ""
' go through each item on list
productn = Cells(x, 1)
' if item is not new then add quanity to total Inventory
With Worksheets("Inventory").Range("A:A")
Set rng = .Find(What:=productn, _
After:=.Cells(.Cells.Count), _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
'if item is new add item to the bottom of Inventory list
If rng Is Nothing Then
erow = Worksheets("Inventory").Cells(1, 1).CurrentRegion.Rows.Count + 1
Worksheets("Inventory").Cells(erow, 1) = Worksheets("Givenaway").Cells(x, 1)
Worksheets("Inventory").Cells(erow, 2) = Worksheets("Givenaway").Cells(x, 2)
Worksheets("Inventory").Cells(erow, 3) = Worksheets("Givenaway").Cells(x, 3)
Worksheets("Inventory").Cells(erow, 4) = Worksheets("Givenaway").Cells(x, 4)
GoTo ende
Else
rownumber = rng.row
End If
End With
Worksheets("Inventory").Cells(rownumber, 2).Value = Worksheets("Inventory").Cells(rownumber, 2).Value _
- Worksheets("Givenaway").Cells(x, 2).Value
Worksheets("Inventory").Cells(rownumber, 4).Value = Worksheets("Inventory").Cells(rownumber, 4).Value _
+ Worksheets("Givenaway").Cells(x, 2).Value
ende:
x = x + 1
Loop
'after complete delete items from Givenaway list
Worksheets("Givenaway").Select
row = 2
Do While Cells(row, 1) <> ""
Range(Cells(row, 1), Cells(row, 3)).Select
Selection.Delete
Loop
Set wsIn = Worksheets("Givenaway")
Set wsData = Worksheets("Databaseinventory")
With wsData
nextRow = .Cells(.Rows.Count, "A") _
.End(xlUp).Offset(1, 0).row
End With
With wsData
With .Cells(nextRow, 1)
.Value = Now
.NumberFormat = "mm/dd/yyyy hh:mm:ss"
End With
.Cells(nextRow, 2).Value = productn
.Cells(nextRow, 3).Value = Worksheets("Databaseinventory").Cells(rownumber, 3).Value _
+ Worksheets("Givenaway").Cells(x, 2).Value
End With
End Sub
This code is deleting the value
Worksheets("Givenaway").Select
row = 2
Do While Cells(row, 1) <> ""
Range(Cells(row, 1), Cells(row, 3)).Select
Selection.Delete
Loop
before this line copies it to Databaseinventory
Cells(nextRow, 3).Value = Worksheets("Databaseinventory").Cells(rownumber, 3).Value _
+ Worksheets("Givenaway").Cells(x, 2).Value
It appears to work if you have 3 rows is because on exit from the Do While Cells(x, 1) <> "" loop the value of x will be 3. After deleting the first record then Worksheets("Givenaway").Cells(x, 2).Value will be the value for the third record.
The database update routine also need to be within the loop
Option Explicit
Sub Btn_Clickweggegeven()
Dim wb As Workbook, rng As Range
Dim wsInv As Worksheet, wsGiven As Worksheet, wsData As Worksheet
Dim iRow As Long, iDataRow As Long, iInvRow As Long
Dim sProduct As String, nValue As Single
Set wb = ThisWorkbook
Set wsGiven = wb.Sheets("GivenAway")
Set wsInv = wb.Sheets("Inventory")
Set wsData = wb.Sheets("Databaseinventory")
iDataRow = wsData.Cells(Rows.Count, 1).End(xlUp).row
iRow = 2
With wsGiven
Do While .Cells(iRow, 1) <> ""
sProduct = .Cells(iRow, 1)
nValue = .Cells(iRow, 2)
' if item is not new then add quanity to total Inventory
With wsInv.Range("A:A")
Set rng = .Find(What:=sProduct, _
After:=.Cells(.Cells.Count), _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
End With
If rng Is Nothing Then
iInvRow = wsInv.Cells(Rows.Count, 1).End(xlUp).row + 1
wsInv.Cells(iInvRow, 1).Resize(1, 4).Value = .Cells(iRow, 1).Resize(1, 4).Value
Else
iInvRow = rng.row
wsInv.Cells(iInvRow, 2).Value = wsInv.Cells(iInvRow, 2).Value - nValue
wsInv.Cells(iInvRow, 4).Value = wsInv.Cells(iInvRow, 4).Value + nValue
End If
' write to database
iDataRow = iDataRow + 1
With wsData.Cells(iDataRow, 1)
.Value = Now
.NumberFormat = "mm/dd/yyyy hh:mm:ss"
.Offset(0, 1) = sProduct ' col B
.Offset(0, 2) = wsInv.Cells(iInvRow, 3).Value + nValue ' col C ??
End With
iRow = iRow + 1
Loop
End With
'delete from GivenAway
wsGiven.Range("A2").Resize(iRow, 3).Delete
MsgBox iRow - 2 & " records processed", vbInformation
End Sub

Userform to search for two criteria, then paste row's data to userform textboxes

I am getting a run-time error '13': type mismatch for one of the lines marked below. I want to be able to have a userform that you can type two criteria into, then it will search for the row that has both of those criteria and paste the corresponding cells' values to the 11 userform textboxes. I'm not sure why it is giving me an error for this line, or if there is a better way to do this.
Private Sub CommandButton1_Click()
txt1.Visible = True
txt2.Visible = True
txt3.Visible = True
txt4.Visible = True
txt5.Visible = True
txt6.Visible = True
txt7.Visible = True
txt8.Visible = True
txt9.Visible = True
txt10.Visible = True
txt11.Visible = True
Dim ws As Worksheet
Set ws = Sheets("The Goods")
ws.Activate
Dim SearchSearch As Variant
SearchSearch = txtsearch.Value
Dim SearchName As Variant
SearchName = txtname.Value
If Trim(txtsearch.Value) = "" Then
MsgBox "Search can't be left blank.", vbOKOnly + vbInformation, "Search"
End If
If Trim(txtname.Value) = "" Then
MsgBox "Name can't be left blank.", vbOKOnly + vbInformation, "Name"
End If
Dim FirstAddress As String, cF As Range
With ThisWorkbook.Sheets("The Goods").Range("D:D") 'txtsearch will be in the range D:D
Set cF = .Find(What:=SearchSearch, _
after:=ActiveCell, _
LookIn:=xlValues, _
LookAt:=xlPart, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlNext, _
MatchCase:=False, _
SearchFormat:=False) ' line that is giving me an error
With ThisWorkbook.Sheets("The Goods").Range("B:B") 'txtname will be in the range B:B
Set cF = .Find(What:=SearchName, _
after:=ActiveCell, _
LookIn:=xlValues, _
LookAt:=xlPart, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlNext, _
MatchCase:=False, _
SearchFormat:=False)
txt1.Value = cF.(0, 5).Value
txt2.Value = cF(0, 3).Value
txt3.Value = cF(0, 6).Value
txt4.Value = cF(0, 7).Value
txt5.Value = cF(0, 8).Value
txt6.Value = cF(0, 9).Value
txt7.Value = cF(0, 10).Value
txt8.Value = cF(0, 11).Value
txt9.Value = cF(0, 12).Value
txt10.Value = cF(0, 13).Value
txt11.Value = cF(0, 14).Value
End With
End With
End Sub
Private Sub CommandButton3_Click()
Dim iExit As VbMsgBoxResult
iExit = MsgBox("Are you sure you want to exit?", vbQuestion + vbYesNo, "Search System")
If iExit = vbYes Then
Unload Me
End If
End Sub
The code below is a simple For Loop, which loops through each cel in Column B and checks for txtname.Value, and using offset to check if Column D value is equal to txtsearch.Value. If both match, then it will write the values for that row into the userform text boxes. You can change the TextBox1 to txt1, etc.
Private Sub CommandButton1_Click()
Dim ws As Worksheet, cel As Range
Set ws = Sheets("The Goods")
For Each cel In ws.Cells(2, 2).Resize(ws.Cells(Rows.Count, 2).End(xlUp).Row).Cells
If cel.Value = Me.txtname.Value And cel.Offset(, 2).Value = Me.txtsearch.Value Then
Me.TextBox1.Value = cel.Offset(, 3).Value 'Change to your textbox naming scheme
Me.TextBox2.Value = cel.Offset(, 1).Value
Me.TextBox3.Value = cel.Offset(, 4).Value
Me.TextBox4.Value = cel.Offset(, 5).Value
Me.TextBox5.Value = cel.Offset(, 6).Value
Me.TextBox6.Value = cel.Offset(, 7).Value
Me.TextBox7.Value = cel.Offset(, 8).Value
Me.TextBox8.Value = cel.Offset(, 9).Value
Me.TextBox9.Value = cel.Offset(, 10).Value
Me.TextBox10.Value = cel.Offset(, 11).Value
Me.TextBox11.Value = cel.Offset(, 12).Value
End If
Next cel
End Sub
I would go with something like this:
Private Sub CommandButton1_Click()
Dim i As Long, rngB As Range, n As Long, arrB, arrD
Dim ws As Worksheet
Dim SearchSearch As Variant, SearchName As Variant
For i = 1 To 11
Me.Controls("txt" & i).Visible = True
Next i
Set ws = ThisWorkbook.Sheets("The Goods")
ws.Parent.Activate
ws.Activate
SearchSearch = Trim(txtsearch.Value)
SearchName = Trim(txtname.Value)
'check the trimmed values
If Len(SearchSearch) = 0 Or Len(SearchName) = 0 Then
MsgBox "'Search' and 'Name' can't be left blank.", vbOKOnly + vbInformation, "Search"
Exit Sub
End If
'get search ranges
Set rngB = ws.Range(ws.Range("B1"), ws.Cells(ws.Rows.Count, "B").End(xlUp))
Set rngD = rngB.Offset(0, 2)
'pull the values into a couple of arrays for faster searching
arrB = rngB.Value
arrD = rngD.Value
'loop over the arrays
For n = 1 To UBound(arrB, 1)
If arrB(n, 1) = SearchName And arrD(n, 1) = SearchSearch Then
'got a hit - populate your textboxes
Set cF = rngB.Cells(n, 1)
txt1.Value = cF.Offset(0, 1).Value 'Col C same row
txt2.Value = cF.Offset(0, 2).Value 'Col D same row
txt3.Value = cF.Offset(0, 3).Value 'Col E same row
'etc etc
'OR do something like this:
With rngB.Cells(n, 1).EntireRow
txt1.Value = .Cells(1, "C").Value
txt1.Value = .Cells(1, "D").Value
txt1.Value = .Cells(1, "E").Value
'etc etc
End With
Exit For
End If
Next
If cF Is Nothing Then MsgBox "No match!"
End Sub

If cell value same with upper cell value

I tried to make macro for my daily job, but i cannot use IF as formula due to so many item in my excel file, so solution is to convert formula to VBA code.
I need help to convert if formula to VBA code in excel as below:
=IF(J2<>J1,AD2-X2,AE1-X2).
Here is an answer to your question. However, it is limited to only work with OP information. Also, if the calculations are taking too long then, you should try setting your calculation to Manual (Formulas->Calculation Options->Manual).
Option Explicit
Public Sub RunIF()
Dim vntOut As Variant
Dim rngSame As Range
With ActiveSheet
Set rngSave = .Range("X2")
If (LCase(Trim(.Range("J2").Value)) <> LCase(Trim(.Range("J1").Value))) Then
vntOut = .Range("AD2").Value - rngSave.Value
Else
vntOut = .Range("AE1").Value - rngSave.Value
End If
.Range("AE2").value = vntOut
Set rngSave = Nothing
End With
End Sub
And here is your code converted to use Column J:
Private Sub CommandButton12_Click()
Dim x As Long
Dim LastRow As Long
Dim i as long
With Sheets("Shipping Schedule")
LastRow = .Cells(.Rows.Count, "J").End(xlUp).Row
For i = 2 to LastRow
set r = .Range("J" & I)
'For Each r In .Range("J2:J" & LastRow)
If LCase(Trim(r.Value)) <> LCase(Trim(r.Offset(-1, 0).Value)) Then
'ae2 = "AD2" - "x2"
r.Offset(0, 21).Value = r.Offset(0, 20).Value - r.Offset(0, 14).Value
Else
'ae2 = "AE1" - "x2"
r.Offset(0, 21).Value = r.Offset(-1, 21).Value - r.Offset(0, 14).Value
End If
set r = nothing
Next i
End With
End Sub
However, you should increment with I instead of for each as the cells are dependent on the previous row and excel may not loop through the range like you would prefer.
Excel Formula to VBA: Fill Column
Sub FillColumn()
Const cCol As Variant = "J" ' Last-Row-Column Letter/Number
Const cCol1 As Variant = "AD"
Const cCol2 As Variant = "X"
Const cCol3 As Variant = "AE"
Const cFirstR As Long = 1 ' First Row
Dim rng As Range ' Last Used Cell in Last-Row-Column
Dim i As Long ' Row Counter
Set rng = Columns(cCol).Find("*", , xlFormulas, , xlByColumns, xlPrevious)
If rng Is Nothing Then Exit Sub
For i = cFirstR To rng.Row - 1
If Cells(i + 1, cCol) <> Cells(i, cCol) Then
Cells(i + 1, cCol3) = Cells(i + 1, cCol1) - Cells(i + 1, cCol2)
Else
Cells(i + 1, cCol3) = Cells(i, cCol3) - Cells(i + 1, cCol2)
End If
Next
End Sub
Private Sub CommandButton12_Click()
Dim x As Long
Dim LastRow As Long
Sheets("Shipping Schedule").Select
With Sheets("Shipping Schedule")
LastRow = .Cells(.Rows.Count, "N").End(xlUp).Row
For Each r In .Range("N2:N" & LastRow)
If r.Value <> "" Then
r.Offset(0, 19).Value = ………………………………….
End if
Next r
End With
End Sub

How can I separate time from time zone and put time in format "yyyy-m hh:mm:ss"?

How can I separate time from time zone and put time in format "yyyy-m hh:mm:ss". Lookin for the column “Time”, create other two columns: “Time*” and “Time_Zone” .
I adapted this code, but some error occur and I put “On Error Resume Next”
For Each ws In Worksheets
For i = 1 To ws.Columns.Count
If ws.Cells(1, i) = "Hour" Then
Set s = ws.Cells(1, i)
LC = s.Column
ws.Columns(LC + 1).Insert
ws.Columns(LC).Copy
ws.Cells(1, LC + 1).PasteSpecial Paste:=xlPasteValues
ws.Cells(1, LC + 1).Value = "Time*"
Exit For
End If
Next i
For i = 1 To ws.Columns.Count
If ws.Cells(1, i) = "Time*" Then
ColLetr = Split(Cells(1, i).Address, "$")(1)
y = i
Exit For
End If
Next i
If ColLetr <> "" Then
lastRow = ws.Cells(Rows.Count, y).End(xlUp).Row
For Each cell In ws.Range(ColLetr & "3:" & ColLetr & lastRow)
If InStr(cell.Value, "/") <> 0 Then
cell.Value = RegexReplace(cell.Value, _
"(\d{2})\/(\d{2})\/(\d{4})", "$3-$2-$1")
End If
cell.NumberFormat = "yyyy-mm-dd hh:mm:ss;#"
If cell.Value <> "" Then
cell.Value = Left(cell.Value, 19)
End If
Next
End If
For i = 1 To ws.Columns.Count
If ws.Cells(1, i) = "Hour" Then
Set s = ws.Cells(1, i)
LC = s.Column
ws.Columns(LC + 2).Insert
ws.Columns(LC).Copy
ws.Cells(1, LC + 2).PasteSpecial Paste:=xlPasteValues
ws.Cells(1, LC + 2).Value = "Time_Zone"
Exit For
End If
Next i
For i = 1 To ws.Columns.Count
If ws.Cells(1, i) = "Time_Zone" Then
ColLetr = Split(Cells(1, i).Address, "$")(1)
y = i
Exit For
End If
Next i
If ColLetr <> "" Then
lastRow = ws.Cells(Rows.Count, y).End(xlUp).Row
For Each c In ws.Range(ColLetr & "3:" & ColLetr & lastRow)
If c.Value <> "" Then
On Error Resume Next
c.Value = Right(c.Value, Len(c.Value) - 20)
End If
Next
End If
Next
Application.ScreenUpdating = False
End Sub
Function RegexReplace(ByVal text As String, _
ByVal replace_what As String, _
ByVal replace_with As String) As String
Application.ScreenUpdating = False
Dim RE As Object
Set RE = CreateObject("vbscript.regexp")
RE.Pattern = replace_what
RE.Global = True
RegexReplace = RE.Replace(text, replace_with)
Application.ScreenUpdating = True
End Function
This code works for me:
Sub test()
Dim ws As Worksheet
Dim rngTime As Range
Dim cell As Range
Dim rngTarget As Range
Dim formatedTime As String
Application.ScreenUpdating = False
For Each ws In Worksheets
With ws
Set rngTime = .Range("1:1").Find(What:="Time", MatchCase:=False, LookAt:=xlWhole)
If Not rngTime Is Nothing Then
rngTime.Offset(, 1).Resize(, 2).EntireColumn.Insert
rngTime.Offset(, 1) = "Time*"
rngTime.Offset(, 2) = "Time_Zone"
lastrow = .Cells(.Rows.Count, rngTime.Column).End(xlUp).Row
Set rngTarget = .Range(.Cells(3, rngTime.Column + 1), .Cells(lastrow, rngTime.Column + 1))
rngTarget.NumberFormat = "yyyy-mm-dd hh:mm:ss;#"
For Each cell In rngTarget
If InStr(cell.Offset(, -1), "/") <> 0 Then
formatedTime = RegexReplace(cell.Offset(, -1), _
"(\d{2})\/(\d{2})\/(\d{4})", "$3-$2-$1")
cell = Trim(Left(formatedTime, 19))
cell.Offset(, 1) = Trim(Mid(formatedTime, 20))
End If
Next cell
End If
End With
Next ws
Application.ScreenUpdating = True
End Sub
Function RegexReplace(ByVal text As String, _
ByVal replace_what As String, _
ByVal replace_with As String) As String
Dim RE As Object
Set RE = CreateObject("vbscript.regexp")
RE.Pattern = replace_what
RE.Global = True
RegexReplace = RE.Replace(text, replace_with)
End Function
Note, that in your picture you're using Time header in column E, but in your're searching Hour column: If ws.Cells(1, i) = "Hour" Then. I use Time header in my code, you could change it in line Set rngTime = .Range("1:1").Find(What:="Time", MatchCase:=False, LookAt:=xlWhole).
Result:

Resources