If Else statement only working for the last row of data in Excel VBA Userform - excel

I'm struggling with something that sounds very simple, but there's something wrong with my code.
I have a userform with 2 textboxes when I type a 'serial number' in textbox 1, the 'RMA Number' in textbox 2 auto populates if the serial number matches an existing field in the 'RMA' column in the sheet.
If it does not match I want textbox2 to clear up or say "No Match"
I did the If-Then-Else type of code but it seems to work only for the very last entry at the moment...
What do I need to change in my code so it can match all the entries AND clear up when the Serial Number does not match??
'Autopopulate RMA# with Serial Number
Private Sub SN_TextBox1_Change()
Dim serial1_id As String
serial1_id = UCase(Trim(SN_TextBox1.Text))
lastrow = Worksheets("RMA Tracker").Cells(Rows.Count, 1).End(xlUp).Row
For i = 1 To lastrow
If UCase(Worksheets("RMA Tracker").Cells(i, 4).Value) = serial1_id Then
RMA_TextBox1.Text = Worksheets("RMA Tracker").Cells(i, 1).Value
Else
RMA_TextBox1.Value = ""
End If
Next i
End Sub

I think you can use Find() method to server your purpose. Below code will find TextBox1 value from RMA column (D:D). If match found then it will return value from Column A:A for matching row to TextBox2. If there is no match the it will show No Match message to TextBox2.
Private Sub CommandButton1_Click()
Dim RMA As String
Dim Rng As Range
RMA = Me.TextBox1
If Trim(RMA) <> "" Then
With Sheets("RMA Tracker").Range("D:D") 'D:D for column 4
Set Rng = .Find(What:=RMA, _
After:=.Range("A1"), _
Lookat:=xlWhole, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False)
If Not Rng Is Nothing Then
Me.TextBox2 = Rng.Offset(0, -3)
Else
Me.TextBox2 = "No Match"
End If
End With
End If
End Sub

Lookup Value in UserForm TextBox
To show multiple results, you have to set MultiLine to True in the properties of RMA_TextBox1.
The Code
Private Sub SN_TextBox1_Change()
Const wsName As String = "RMA Tracker"
Const FirstRow As Long = 1
Const RMACol As Variant = "A"
Const IdCol As Variant = "D"
Const IfNot As String = "No Match"
Dim wb As Workbook: Set wb = ThisWorkbook
Dim ws As Worksheet: Set ws = wb.Worksheets(wsName)
Dim LastRow As Long: LastRow = ws.Cells(ws.Rows.Count, IdCol).End(xlUp).Row
Dim SerialID As String: SerialID = Trim(SN_TextBox1.Value)
Dim i As Long, Result As String
For i = FirstRow To LastRow
If StrComp(ws.Cells(i, IdCol).Value, SerialID, vbTextCompare) = 0 Then
If Result <> "" Then
Result = Result & vbLf & ws.Cells(i, RMACol).Value
Else
Result = ws.Cells(i, RMACol).Value
End If
End If
Next i
If Result <> "" Then
RMA_TextBox1.Value = Result
Else
RMA_TextBox1.Value = IfNot
End If
End Sub

Related

Highlighting Values In Column to Column Comparison using VBA

I am attempting to compare two columns in two separate sheets, each column contains data that is a string. My issue is that there is data in one column that is identical to the other in separate rows; therefore I have to check the entire column for the data before moving to the next. I am very inexperienced with VBA and am trying to make one portion of my job easier rather than comparing the columns by hand. I have piece wised the following code from research and trial and error. I am able to get the entire Column searched in my first Sheet, but only one value is being highlighted on the second sheet and then it is returning a value of "True" in the first column. I am unsure where I have gone wrong, any help is greatly appreciated!
Sub Better_Work_This_Time()
Dim FindString As String
Dim Rng As Range
ActiveCell = Sheets("Last Week").Range("A2").Activate
FindString = ActiveCell
Dim County As Integer
Count = Cells.CurrentRegion.rows.Count
For i = 2 To County
If Trim(FindString) <> "" Then
With Sheets("Current Week").Range("A:A")
Set Rng = .Find(What:=FindString, After:=.Cells(.Cells.Count), LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=True)
If Not Rng Is Nothing Then
ActiveCell.Font.Color = vbBlue
End If
End With
End If
If IsEmpty(FindString) Then
FindString = False
End If
ActiveCell.Offset(1, 0).Select
i = i + 1
Next
End Sub
Without using ActiveCell and using Match instead of Find.
Option Explicit
Sub Does_Work_This_Time()
Dim wb As Workbook, wsLast As Worksheet, wsCurrent As Worksheet
Dim FindString As String, ar, v
Dim LastRow As Long, i As Long, n As Long
Set wb = ThisWorkbook
' put current week values into array
Set wsCurrent = wb.Sheets("Current Week")
With wsCurrent
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
ar = .Range("A2:A" & LastRow).Value2
End With
' scan last week matching current week
Set wsLast = wb.Sheets("Last Week")
With wsLast
.Columns(1).Interior.Color = xlNone
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
For i = 2 To LastRow
FindString = Trim(.Cells(i, "A"))
If Len(FindString) > 0 Then
v = Application.Match(FindString, ar, 0)
If IsError(v) Then
'no match
ElseIf ar(v, 1) = FindString Then ' case match
.Cells(i, "A").Interior.Color = RGB(128, 255, 128) ' light green
n = n + 1
End If
End If
Next
End With
MsgBox n & " rows matched"
End Sub

Search for all values between 2 values in a column and loop till last one found

Lets start with I am self taught in Excel VBA and have a question that might seem stupid or basic:
I have the following information on a sheet:
[ConfBlastPlan]
DRB1065
PU1962;427;05_37_OB;A;2;2;1
PU1963;364;05_37_OB;B;2;2;1
PU1959;373;05_37_OB;C;2;2;1
-
[FiringProcedure]11:55:21;MULTI
What I want to do is combine all strings between with "PU" and the first ";" that is found between the
"[ConfBlastPlan]" and [FiringProcedure] into one cell.
I have read up about the loop function but seems I have confused myself terribly.
How do I loop this and combine the strings found?
I have started the function using the following code:
Sub DRBEquipNumberPU() 'GET THE PU#s
Dim WSFrom As Worksheet
Dim WSTo As Worksheet
Dim RngFrom As Range
Dim RngTo As Range
Dim BlastNumber As String
Dim BlastNumberStep As Long
Dim SearchString As String
Dim SearchStringStart As String
Dim SearchStringEnd As String
Dim LineStep As Long
Dim Blastedrng As Range
Dim BlastedFoundrng As Range
Dim closePos As Integer
BlastNumberStep = 1
LineStep = 1
Set Blastedrng = ThisWorkbook.Worksheets("Blast Summary Sheet").Range("A2", Range("A2").End(xlDown))
For Each BlastedFoundrng In Blastedrng.Cells
On Error Resume Next
SearchString = "[ConfBlastPlan]"
SearchStringStart = "PU"
SearchStringEnd = "[FiringProcedure]"
BlastNumber = CStr("Blasted " & BlastNumberStep)
Set WSFrom = Worksheets(CStr(BlastNumber))
Set RngFrom = WSFrom.Cells.Find(What:=SearchString, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, _
SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
Set RngFrom1 = WSFrom.Cells.Find(What:=SearchStringStart, After:=RngFrom, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, _
SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
Set WSTo = ThisWorkbook.Worksheets("Blast Summary Sheet")
Set RngTo = WSTo.Cells.Find(What:=(CStr(BlastNumber)), LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, _
SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
closePos = InStr(1, RngFrom.Cells.Value, ";")
If RngTo.Cells.Offset(0, 4).Value = "INCOMPLT" Then
RngTo.Cells.Offset(0, 7).Value = "INCOMPLT"
ElseIf RngFrom.Cells.Value Is Nothing Then
RngTo.Cells.Offset(0, 7).Value = "NO PU #s"
ElseIf RngFrom.Cells.Value Like SearchStringStart Then
RngTo.Cells.Offset(0, 7).Value = Mid(RngFrom.Cells.Value, 0, closePos)
ElseIf RngFrom.Cells.Value = SearchStringEnd Then
End If
BlastNumberStep = BlastNumberStep + 1
Next BlastedFoundrng
End Sub
All it returns at the moment is INCOMPL or NO PU #s
There can be a maximum of 48 instances of PU
Please help
Blasted 23:
Blasted 26:
Blasted 27:
Option Explicit
' Major changes: make it two steps-- 1)Get all Sheet names, 2)Process all Lines on one sheet
Sub StepThruBlastedSheetNames() 'GET THE PU#s
Dim WSSummary As Worksheet, rowSummary As Long
Set WSSummary = ThisWorkbook.Worksheets("Blast Summary Sheet")
rowSummary = 1
Dim WSFrom As Worksheet
For Each WSFrom In ThisWorkbook.Worksheets
If InStr(WSFrom.Name, "Blasted ") > 0 Then
StepThruBlastedLines WSSummary, rowSummary, WSFrom
End If
Next
End Sub
Sub StepThruBlastedLines(WSSummary As Worksheet, rowSummary As Long, WSFrom As Worksheet)
' these never change, ergo do not put inside loop
Const SearchStringStart As String = "[ConfBlastPlan]"
Const SearchStringFindPU As String = "PU"
Const SearchStringEnd As String = "[FiringProcedure]"
Dim rowFrom As Long
Dim rowMax As Long
rowMax = WSFrom.Cells(WSFrom.Rows.Count, "A").End(xlUp).Row
Dim IsBetween As String, PUlist As String, posSemi As Long, DRBname As String
IsBetween = "N"
PUlist = ""
DRBname = ""
For rowFrom = 1 To rowMax
If IsBetween = "Y" Then
If InStr(WSFrom.Cells(rowFrom, "A"), "DRB") > 0 Then
DRBname = WSFrom.Cells(rowFrom, "A")
End If
If InStr(WSFrom.Cells(rowFrom, "A"), SearchStringFindPU) > 0 Then
posSemi = InStr(WSFrom.Cells(rowFrom, "A"), ";")
PUlist = PUlist & Mid(WSFrom.Cells(rowFrom, "A"), 1, posSemi)
End If
If InStr(WSFrom.Cells(rowFrom, "A"), SearchStringEnd) > 0 Then
IsBetween = "N"
rowSummary = rowSummary + 1
WSSummary.Cells(rowSummary, "A") = WSFrom.Name
WSSummary.Cells(rowSummary, "B") = DRBname
If PUlist <> "" Then
WSSummary.Cells(rowSummary, "C") = PUlist
PUlist = ""
Else
'<< add put empty notice
WSSummary.Cells(rowSummary, "C") = "INCOMPL"
End If
DRBname = "" '<<added
End If
ElseIf WSFrom.Cells(rowFrom, "A") = SearchStringStart Then
IsBetween = "Y"
End If
Next rowFrom
End Sub
Here's code that extracts the PU-values from a worksheet like the one you posted. I couldn't figure out why you called this worksheet WsTo and perhaps that's the reason why I also couldn't guess at your intention for what to do with the result. Your question is mute on the point. So I left the project at that point. I'm sure you will be able to pick it up from the two ways I'm displaying the Output array.
Sub DRBEquipNumberPU()
' 134
' Get the PU#s
Const Blast As String = "[ConfBlastPlan]"
Const BlastEnd As String = "-"
Const Marker As String = "PU"
Dim WsTo As Worksheet
Dim BlastFound As Range
Dim CellVal As String ' loop variable: Cell.Value
Dim R As Long ' loop counter: rows
Dim Output As Variant ' array of found values
Dim i As Long ' index to Output
Set WsTo = ThisWorkbook.Worksheets("Blast Summary Sheet")
With WsTo.Columns(1)
Set BlastFound = .Find(What:=Blast, _
LookIn:=xlValues, _
Lookat:=xlWhole, _
MatchCase:=False)
If BlastFound Is Nothing Then
MsgBox """" & Blast & """ wasn't found.", _
vbInformation, "No data to process"
Else
ReDim Output(1 To 100) ' choose UBound larger than you ever need
R = BlastFound.Row
Do
R = R + 1
CellVal = .Cells(R).Value
If InStr(1, Trim(CellVal), Marker, vbTextCompare) = 1 Then
i = i + 1
Output(i) = CellVal
End If
Loop While Len(CellVal) And CellVal <> BlastEnd
If i Then
ReDim Preserve Output(1 To i)
MsgBox "Found values = " & vbCr & _
Join(Output, Chr(13))
For i = LBound(Output) To UBound(Output)
Debug.Print Output(i)
Next i
End If
End If
End With
End Sub
It just occurs to me that the end marker you suggested ("FiringProcedure]") may be more reliable than my choice ("-"). If so, just change it at the top of the code where the constants are declared. If that marker is missed the code might continue to include the "PU" line below the [Blasting Plan] row.

Loop through cells and display a message if a value is not found

I have a macro that loops through cells of one sheet, looks for that value in another sheet, and then highlights the row if they match. I'd like to add a message box that would pop up if a matching value is not found. I know this is a simple problem, but I'm having trouble figuring out in which loop to put my booleans.
Sub MarkXfer_noX()
Dim rng As Range
Dim rng2 As Range
Set rng = Worksheets("Transferred Routings").UsedRange
Dim i As Integer
Dim j As Integer
Dim ProdCI As String
Dim found As Boolean
Dim intRowCount As Integer
intRowCount = Sheets("Transferred Routings").UsedRange.Rows.count
For i = 2 To intRowCount
If rng.Cells(i, 1) <> "" Then ProdCI = rng.Cells(i, 1) 'get the ProdCI number from column A if not blank
Worksheets("All_ProCI").Activate 'activate main page
Set rng2 = Worksheets("All_ProCI").UsedRange 'select a range on the main page
For j = 2 To rng2.Rows.count 'from row 2 to the end
If rng2.Cells(j, 2) = ProdCI Then 'if the ProdCI in column B matches the one we picked,
Call FillCell(j) 'call a sub in a different module and give it our current row
found = True
Else
found = False
End If
Next
Next
If found = False Then
MsgBox (ProdCI & " not found") 'Display a message if one of the items wasn't found on the main page. Currently has an error where the last one in the list always pops up.
Else
End If
End Sub
Right now it always shows a msgbox with the last value in the range no matter what.
Thanks all, here is the updated working code using the Find function
Sub MarkXfer_Find()
'Re-tooled to use the .Find function instead of looping through each
Dim rng As Range
Dim rng2 As Range
Set rng = Worksheets("Transferred Routings").UsedRange
Dim i As Integer
Dim ProdCI As String
Dim intRowCount As Integer
Dim intRowCount2 As Integer
Dim aCell As Range
intRowCount = Sheets("Transferred Routings").UsedRange.Rows.count
For i = 2 To intRowCount
If rng.Cells(i, 1) <> "" Then ProdCI = rng.Cells(i, 1) 'get the ProdCI number from column A if not blank
Worksheets("All_ProCI").Activate 'activate main page
Set rng2 = Worksheets("All_ProCI").UsedRange 'select a range on the main page
intRowCount2 = Worksheets("All_ProCI").UsedRange.Rows.count
'use the Find function to put a value in aCell
Set aCell = rng2.Range("B1:B" & intRowCount2).Find(What:=ProdCI, LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
If Not aCell Is Nothing Then
'MsgBox ProdCI & " found"
Call FillCell(aCell.row)
Else 'If aCell is blank display msgbox
MsgBox "ProdCI """ & ProdCI & """ not found"
End If
Next
End Sub

Check if all column values exists in another list

The excel vba macro I have created goes through an entire column and searches each value in the column against another column found on another worksheet. I have a T/F column where I mark down "T" if it is found, "F" if it is not found. However, I feel like the way I am doing it might not be very efficient, as the macro takes about 30 minutes to go through 31,000 rows of values to be searched from another column with about 27,000 number of values.
For a simple illustration, I have included a few images which explains what the macro does.
Initially the T/F column will be empty. Only after executing the macro, would it be filled. I loop through each row in column A and try to find the value against the SearchCol in the next picture.
Here is the vba code I am currently using.
Sub CheckIfValuesExist()
Dim ActiveWS As Worksheet, WS2 As Worksheet
Dim ValueColLetter As String, SearchColLetter As String, TFColLetter As String
Dim LastRow As Long, i As Long
Dim target As Variant, rng As Range
Set ActiveWS = ActiveWorkbook.Worksheets(1)
Set WS2 = ActiveWorkbook.Worksheets(2)
ValueColLetter = "A"
SearchColLetter = "A"
TFColLetter = "B"
LastRow = ActiveWS.Cells.Find(What:="*", SearchOrder:=xlRows, _
SearchDirection:=xlPrevious, _
LookIn:=xlFormulas).Row
For i = 2 To LastRow
target = ActiveWS.Range(ValueColLetter & i).Value
If target <> "" Then
With WS2.Range(SearchColLetter & ":" & SearchColLetter) 'searches all of column A
Set rng = .Find(What:=target, _
After:=.Cells(.Cells.Count), _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
If Not rng Is Nothing Then
ActiveWS.Range(TFColLetter & i).Value = "T" 'value found
Else
ActiveWS.Range(TFColLetter & i).Value = "F" 'value not found
End If
End With
End If
Next i
End Sub
The macro works as intended, I just find it to be slow. Is there any better way to do the same thing but in a quicker manner?
Check Column Against Column
Array Match Range Version
Sub CheckIfValuesExist()
Const cSheet1 As Variant = 1 ' Value Worksheet Name/Index
Const cSheet2 As Variant = 2 ' Search Worksheet Name/Index
Const cFirst As Long = 2 ' First Row
Const cVal As Variant = "A" ' Value Column
Const cSrc As Variant = "A" ' Search Column
Const cTF As Variant = "B" ' Target Column
Const cT As String = "T" ' Found String
Const cF As String = "F" ' Not Found String
Dim RngS As Range ' Search Range
Dim vntV As Variant ' Value Array
Dim vntT As Variant ' Target Array
Dim LastV As Long ' Value Last Column Number
Dim LastS As Long ' Search Last Column Number
Dim i As Long ' Value/Target Row Counter
Dim dummy As Long ' Match Dummy Variable
With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With
On Error GoTo ProcedureExit
With ThisWorkbook.Worksheets(cSheet1)
LastV = .Columns(.Cells(1, cVal).Column).Find("*", , -4123, , 2, 2).Row
vntV = .Range(.Cells(cFirst, cVal), .Cells(LastV, cVal))
End With
With ThisWorkbook.Worksheets(cSheet2)
LastS = .Columns(.Cells(1, cSrc).Column).Find("*", , -4123, , 2, 2).Row
Set RngS = .Range(.Cells(cFirst, cSrc), .Cells(LastS, cSrc))
ReDim vntT(1 To UBound(vntV), 1 To 1)
For i = 1 To UBound(vntV)
On Error Resume Next
If vntV(i, 1) <> "" Then
dummy = Application.Match(vntV(i, 1), RngS, 0)
If Err Then
vntT(i, 1) = cF
Else
vntT(i, 1) = cT
End If
End If
On Error GoTo 0
Next
End With
On Error GoTo ProcedureExit
With ThisWorkbook.Worksheets(cSheet1)
.Range(.Cells(cFirst, cTF), .Cells(.Rows.Count, cTF)).ClearContents
.Cells(cFirst, cTF).Resize(UBound(vntT)) = vntT
End With
ProcedureExit:
With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With
End Sub
Let us assume that data included in Sheet 1.
Try:
Option Explicit
Sub VlookUp()
Dim LastRowSV As Long, LastRowV As Long, Counts As Long
Dim wsName As String
Dim wsListSV As Range, cellSV As Range, wsListV As Range, cellV As Range
With ThisWorkbook.Worksheets("Sheet1")
'Find the last row of Search Values
LastRowSV = .Cells(.Rows.Count, "D").End(xlUp).Row
'Find the last row of Values
LastRowV = .Cells(.Rows.Count, "A").End(xlUp).Row
'Set the list with the Search Values
Set wsListSV = .Range(Cells(2, 4), Cells(LastRowSV, 4))
'Set the list with the Values
Set wsListV = .Range(Cells(3, 1), Cells(LastRowV, 1))
'Loop each value in Search Values
For Each cellV In wsListV
Counts = Application.WorksheetFunction.CountIf(wsListSV, cellV)
If Counts <> 0 Then
cellV.Offset(0, 1).Value = "T"
Else
cellV.Offset(0, 1).Value = "F"
End If
Next
End With
End Sub
Result:
Why don't you use the MATCH formula?
If your values are in Col A and the search values are at
the cells $F$5:$F$10 the formula is:
=MATCH(A2,$F$5:$F$10,0)
or if you insist on a T/F result:
=IF(ISERROR(MATCH(A2,$F$5:$F$10,0)),"T","F")
Of cause you can insert this formula also with a macro.

Vba delete rows if cell in range is blank?

I have a worksheet like so:
Column A < - - - -
A |
B - - - - Range A30:A39
C |
|
< - - - -
Next Line
Text way down here
I am using this code to delete the empty cells in my range A30:39. This range sits above the 'Next Line' value.
wStemplaTE.Range("A30:A39").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
In an ideal world, this code should cause this to happen:
Column A
A
B
C
Next Line
Text way down here
But instead it's causing the last bit of text to shift upwards like this:
Column A
A
B
C
Next Line
Text Way down here
Next Line and Text way down here are not even in this range.
Can someone show me what i am doing wrong?
My Entire code:
Sub Create()
'On Error GoTo Message
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Dim WbMaster As Workbook
Dim wbTemplate As Workbook
Dim wStemplaTE As Worksheet
Dim i As Long
Dim LastRow As Long
Dim rngToChk As Range
Dim rngToFill As Range
Dim rngToFill2 As Range
Dim rngToFill3 As Range
Dim rngToFill4 As Range
Dim rngToFill5 As Range
Dim rngToFill6 As Range
Dim rngToFill7 As Range
Dim rngToFill8 As Range
Dim rngToFill9 As Range
Dim rngToFil20 As Range
Dim CompName As String
Dim TreatedCompanies As String
Dim FirstAddress As String
'''Reference workbooks and worksheet
Set WbMaster = ThisWorkbook
'''Loop through Master Sheet to get company names
With WbMaster.Sheets(2)
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
'''Run Loop on Master
For i = 2 To LastRow
'''Company name
Set rngToChk = .Range("B" & i)
CompName = rngToChk.value
If InStr(1, TreatedCompanies, CompName) Or CompName = vbNullString Then
'''Company already treated, not doing it again
Else
'''Open a new template
Set wbTemplate = Workbooks.Open("G:\BUYING\Food Specials\2. Planning\3. Confirmation and Delivery\Announcements\Templates\template.xlsx")
Set wStemplaTE = wbTemplate.Sheets(1)
'''Set Company Name to Template
wStemplaTE.Range("C12").value = CompName
wStemplaTE.Range("C13").value = rngToChk.Offset(, 1).value
wStemplaTE.Range("C14").value = rngToChk.Offset(, 2).value
wStemplaTE.Range("C15").value = rngToChk.Offset(, 3).value
wStemplaTE.Range("C16").value = Application.UserName
wStemplaTE.Range("C17").value = Now()
wStemplaTE.Range("A20").value = "Announcement of Spot Buy Promotion - Week " & ThisWorkbook.Worksheets(1).Range("I8").value & " " & ThisWorkbook.Worksheets(1).Range("T8").value
Dim strDate
Dim strResult
strDate = rngToChk.Offset(, 14).value
wStemplaTE.Range("C25").value = "Week " & ThisWorkbook.Worksheets(1).Range("I8").value & " " & ThisWorkbook.Worksheets(1).Range("T8").value & " " & WeekdayName(Weekday(strDate)) & " (" & strDate & ")"
'Set Delivery Date
wStemplaTE.Range("C26").value = WeekdayName(Weekday(rngToChk.Offset(, 15).value)) & " (" & rngToChk.Offset(, 15).value & ")"
'''Add it to to the list of treated companies
TreatedCompanies = TreatedCompanies & "/" & CompName
'''Define the 1st cell to fill on the template
Set rngToFill = wStemplaTE.Range("A30")
Set rngToFill2 = wStemplaTE.Range("B30")
Set rngToFill3 = wStemplaTE.Range("C30")
Set rngToFill4 = wStemplaTE.Range("D30")
Set rngToFill5 = wStemplaTE.Range("E30")
Set rngToFill6 = wStemplaTE.Range("F30")
Set rngToFill7 = wStemplaTE.Range("G30")
Set rngToFill8 = wStemplaTE.Range("C13")
Set rngToFill9 = wStemplaTE.Range("C14")
Set rngToFil20 = wStemplaTE.Range("C15")
With .Columns(2)
'''Define properly the Find method to find all
Set rngToChk = .Find(What:=CompName, _
After:=rngToChk.Offset(-1, 0), _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlNext, _
MatchCase:=False, _
SearchFormat:=False)
'''If there is a result, keep looking with FindNext method
If Not rngToChk Is Nothing Then
FirstAddress = rngToChk.Address
Do
'''Transfer the cell value to the template
rngToFill.value = rngToChk.Offset(, 7).value
rngToFill2.value = rngToChk.Offset(, 8).value
rngToFill3.value = rngToChk.Offset(, 9).value
rngToFill4.value = rngToChk.Offset(, 10).value
rngToFill5.value = rngToChk.Offset(, 11).value
rngToFill6.value = rngToChk.Offset(, 12).value
rngToFill7.value = rngToChk.Offset(, 13).value
'''Go to next row on the template for next Transfer
Set rngToFill = rngToFill.Offset(1, 0)
Set rngToFill2 = rngToFill.Offset(0, 1)
Set rngToFill3 = rngToFill.Offset(0, 2)
Set rngToFill4 = rngToFill.Offset(0, 3)
Set rngToFill5 = rngToFill.Offset(0, 4)
Set rngToFill6 = rngToFill.Offset(0, 5)
Set rngToFill7 = rngToFill.Offset(0, 6)
'''Look until you find again the first result
Set rngToChk = .FindNext(rngToChk)
Loop While Not rngToChk Is Nothing And rngToChk.Address <> FirstAddress
Else
End If
End With '.Columns(2)
Set Rng = Range("D30:G39")
Rng.Select
Set cell = Selection.Find(What:="#VALUE!", After:=ActiveCell, LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
If cell Is Nothing Then
'do it something
Else
For Each cell In Rng
cell.value = "TBC"
Next
'End For
wStemplaTE.Range("A41").value = "Please fill in the pallet factor and case size accordingly. Please amend total volume if necessary to accommodate full pallets."
End If
Rng.Select
Set cell = Selection.Find(What:="TBC", After:=ActiveCell, LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
If cell Is Nothing Then
'do it something
Else
wStemplaTE.Range("A41").value = "Please fill in the pallet factor and case size accordingly. Please amend total volume if necessary to accommodate full pallets."
End If
'Remove uneeded announcement rows
wStemplaTE.Range("A30:A39").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
file = AlphaNumericOnly(CompName)
wbTemplate.SaveCopyAs filename:="G:\BUYING\Food Specials\2. Planning\3. Confirmation and Delivery\Announcements\2017\test\" & file & ".xlsx"
wbTemplate.Close False
End If
Next i
End With 'wbMaster.Sheets(2)
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Dim answer As Integer
answer = MsgBox("Announcements Successfully Created." & vbNewLine & vbNewLine & "Would you like to view these now?", vbYesNo + vbQuestion, "Notice")
If answer = vbYes Then
Call List
Else
'do nothing
End If
Exit Sub
Message:
wbTemplate.Close savechanges:=False
MsgBox "One or more files are in use. Please make sure all Announcement files are closed and try again."
Exit Sub
End Sub
Function AlphaNumericOnly(strSource As String) As String
Dim i As Integer
Dim strResult As String
For i = 1 To Len(strSource)
Select Case Asc(Mid(strSource, i, 1))
Case 48 To 57, 65 To 90, 97 To 122: 'include 32 if you want to include space
strResult = strResult & Mid(strSource, i, 1)
End Select
Next
AlphaNumericOnly = strResult
End Function
Function FindAll(SearchRange As Range, _
FindWhat As Variant, _
Optional LookIn As XlFindLookIn = xlValues, _
Optional LookAt As XlLookAt = xlWhole, _
Optional SearchOrder As XlSearchOrder = xlByRows, _
Optional MatchCase As Boolean = False, _
Optional BeginsWith As String = vbNullString, _
Optional EndsWith As String = vbNullString, _
Optional BeginEndCompare As VbCompareMethod = vbTextCompare) As Range
End Function
Modify the column as you need. Right now it is working on column A. You can make it an argument to ask the user, like the second code
Public Sub DeleteRowOnCell()
'====================================================================================
'This macro will delete the entire row if a cell in the specified column is blank.
'Only one specified column is checked. Other columns are ignored.
'====================================================================================
On Error Resume Next
Range("A3:A" & Rows.count).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
On Error GoTo 0
End Sub
Public Sub DeleteRowOnCellAsk()
'====================================================================================
'This macro will delete the entire row if a cell in the specified column is blank.
'Only one specified column is checked. Other columns are ignored.
'====================================================================================
Dim inp As String
inp = InputBox("Please enter a column name based on which blank rows will be deleted", "Which Column?")
Debug.Print inp & ":" & inp & Rows.count
On Error Resume Next
Range(inp & "1" & ":" & inp & Rows.count).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End Sub

Resources