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
Related
I have a few spreadsheets with various tables in different formats. My task is to locate and identify anything on the spreadsheets that can be considered a table, and flatten it into a text file. Currently I am only looking for a solution to locate all tables on one spreadsheet.
The rules are:
Spreadsheet format is somewhat fixed, I have to process what I am given.
A completely empty line can split a table into two, unless there's a sure way to tell what is a missing line within one table and what is an actual new table.
I can handle merged fields beforehand if needs be (split them and backfill with the common value, that's already written and is working)
The tables could have a different number of columns, different header rows, and they could begin in any column.
I consider records in the same line to be part of the same table, I am not expecting to find tables next to one another.
The code I have so far as follows:
Sub Find_All_Tables()
'Finds all the separate tables in the worksheet
Dim rStart As Range, rFoundStart As Range, rFoundEnd As Range
Dim lRow As Long, lCol As Long
lRow = Cells.Find(What:="*", _
After:=Range("A1"), _
LookAt:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
lCol = Cells.Find(What:="*", _
After:=Range("A1"), _
LookAt:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Column
MsgBox "Last non-empty cell on the spreadsheet is " & Cells(lRow, lCol).Address
Set rStart = Range("A1")
MsgBox rStart.Row
While rStart.Row < lRow
On Error Resume Next
Set rFoundStart = Cells.Find(What:="*", _
After:=rStart, _
LookAt:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
On Error GoTo 0
If rFoundStart Is Nothing Then
MsgBox "All cells are blank."
Else
rFoundStart.End(xlToRight).End(xlDown).Select
Set rFoundEnd = Selection
'MsgBox "First Cell: " & rFoundStart.Address
'MsgBox "Last Cell: " & ActiveCell.Address
Range(rFoundStart.Address, rFoundEnd.Address).Select
MsgBox "There is a table between " & rFoundStart.Address & " and " & rFoundEnd.Address
End If
Set rStart = Range("A" & rFoundEnd.Row + 1)
Wend
End Sub
The sample sheet I am looking at is as messy as possible to account for "creative" formatting.
The error I'm getting is due to the fact that the second table starts from B7 and ends in E1048576, which is well past the loop condition - I would like this range to end in E8 (or E9 if possible or once the merged cells are broken up).
I've got this code from way back when.... 2008.
No idea if it works with ListObject tables.
Original MrExcel post: Find all lists in a workbook
Sub Test()
Dim aLists As Variant
Dim aLists1 As Variant
'//Find lists in a different workbook.
'' aLists = FindRegionsInWorkbook(Workbooks("Test Workbook.xls"))
'//Find lists in the this workbook.
aLists1 = FindRegionsInWorkbook(ThisWorkbook)
Debug.Assert False
End Sub
'//Returns each region in each worksheet within the workbook in the 'sRegion' variable.
'//
'//Written by Zack Barresse (MVP), Oregon, USA.
'//
'//http://www.mrexcel.com/forum/showthread.php?t=309052
Public Function FindRegionsInWorkbook(wrkBk As Workbook) As Variant
Dim ws As Worksheet, rRegion As Range, sRegion As String, sCheck As String
Dim sAddys As String, arrAddys() As String, aRegions() As Variant
Dim iCnt As Long, i As Long, j As Long
'//Cycle through each worksheet in workbook.
j = 0
For Each ws In wrkBk.Worksheets
sAddys = vbNullString
sRegion = vbNullString
On Error Resume Next
'//Find all ranges of constant & formula valies in worksheet.
sAddys = ws.Cells.SpecialCells(xlCellTypeConstants, 23).Address(0, 0) & ","
sAddys = sAddys & ws.Cells.SpecialCells(xlCellTypeFormulas, 23).Address(0, 0)
If Right(sAddys, 1) = "," Then sAddys = Left(sAddys, Len(sAddys) - 1)
On Error GoTo 0
If sAddys = vbNullString Then GoTo SkipWs
'//Put each seperate range into an array.
If InStr(1, sAddys, ",") = 0 Then
ReDim arrAddys(1 To 1, 1 To 2)
arrAddys(1, 1) = ws.Name
arrAddys(1, 2) = sAddys
Else
arrAddys = Split(sAddys, ",")
For i = LBound(arrAddys) To UBound(arrAddys)
arrAddys(i) = "'" & ws.Name & "'!" & arrAddys(i)
Next i
End If
'//Place region that range sits in into sRegion (if not already in there).
For i = LBound(arrAddys) To UBound(arrAddys)
If InStr(1, sRegion, ws.Range(arrAddys(i)).CurrentRegion.Address(0, 0)) = 0 Then
sRegion = sRegion & ws.Range(arrAddys(i)).CurrentRegion.Address(0, 0) & "," '*** no sheet
sCheck = Right(arrAddys(i), Len(arrAddys(i)) - InStr(1, arrAddys(i), "!"))
ReDim Preserve aRegions(0 To j)
aRegions(j) = Left(arrAddys(i), InStr(1, arrAddys(i), "!") - 1) & "!" & ws.Range(sCheck).CurrentRegion.Address(0, 0)
j = j + 1
End If
Next i
SkipWs:
Next ws
On Error GoTo ErrHandle
FindRegionsInWorkbook = aRegions
Exit Function
ErrHandle:
'things you might want done if no lists were found...
End Function
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.
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
I have range of products that are routinely tested every quarter, each product is tested once annually.
I need an excel VBA that prompts the user to input what product was tested and then prompt the user to input in which quarter (e.g. Q1,Q2 etc ) the product was tested. Then in a specific column this information about which quarter the product is tested is displayed and inputted into a cell.
I then want to be able to keep track of this information about which quarter each product was tested every year so for the next test for each product, would like excel to fill the row next to it. Shown below is an visual example of what I'm trying to achieve.
Example of Excel Worksheet
Also attached is the code I have been trying mould to fit my problem.
Dim myValue As Variant
myValue = InputBox("Give me some input")
Dim SearchString As String
Dim SearchRange As Range, cl As Range
Dim FirstFound As String
Dim sh As Worksheet
' Set Search value
SearchString = myValue
Application.FindFormat.Clear
' loop through all sheets
For Each sh In ActiveWorkbook.Worksheets
' Find first instance on sheet
Set cl = sh.Cells.Find(What:=SearchString, _
After:=sh.Cells(1, 1), _
LookIn:=xlValues, _
LookAt:=xlPart, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False, _
SearchFormat:=False)
If Not cl Is Nothing Then
' if found, remember location
FirstFound = cl.Address
' format found cell
Do
cl.Font.Bold = True
cl.Interior.ColorIndex = 3
' find next instance
Set cl = sh.Cells.FindNext(After:=cl)
' repeat until back where we started
Loop Until FirstFound = cl.Address
End If
Next
End Sub
In your code you have this line to get the product
myValue = InputBox("Give me some input")
Just add another line to get the Quarter
myValue2 = InputBox("Give me some more input")
The search command is working correctly although it could be made more efficient by restricting the search to the first column not the whole sheet.
Set cl = sh.Cells.Find(What:=SearchString, _
After:=sh.Cells(1, 1), _
LookIn:=xlValues, _
LookAt:=xlPart, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False, _
SearchFormat:=False)
To match the whole string rather than a part change the parameter LookAt:=xlWhole.
If you only have one product that matches the user input then this code can be deleted.
Do
cl.Font.Bold = True
cl.Interior.ColorIndex = 3
' find next instance
Set cl = sh.Cells.FindNext(After:=cl)
' repeat until back where we started
Loop Until FirstFound = cl.Address
The row number is found simply with
rowno = cl.Row
The next part you seem to be having difficulty with is locating the next available
blank column in that row. The VBA is as a user would do by using Ctrl-CursorLeft
from the end column.
colno = ws.range(rowno,Columns.count).End(xlToLeft.Column +1
Since it's very unlikely your sheet will span more 702 years this might be clearer
colno = ws.range("ZZ" & rowno).End(xlToLeft).Column + 1
Now update that cell
wc.cell(rowno,colno) = Value2
Put those components together using sensible variable names, add some validation on what the user is entering, insert some debugging messages at critical points and you should get something like this ;
Sub enterdata()
Const DBUG As Boolean = False ' set to TRUE to see each step
Const YR1COL = 5 'E
Dim wb As Workbook, ws As Worksheet
Set wb = ThisWorkbook
Dim sProduct As String
Dim iRowno As Long, iQu As Integer, iColno As Integer
Dim rng As Range, iLastRow As Long, wsMatch As Worksheet, cellMatch As Range
Dim chances As Integer: chances = 3
LOOP1: ' get valid product
sProduct = InputBox(Title:="Input Product", prompt:="Product is ")
If DBUG Then Debug.Print sProduct
If Len(sProduct) > 0 Then
' search through all sheets
For Each ws In wb.Sheets
iLastRow = ws.Range("A" & ws.Rows.count).End(xlUp).Row
If DBUG Then Debug.Print ws.Name & " " & iLastRow
' Search col A of sheet using xlWhole for exact match
Set rng = ws.Range("A2:A" & iLastRow) ' avoid header
Set cellMatch = rng.Find( _
What:=sProduct, _
After:=rng.Cells(2, 1), _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False, _
SearchFormat:=False)
' exit on first match
If Not cellMatch Is Nothing Then
Set wsMatch = ws
GoTo LOOP2
End If
Next
Else
Exit Sub
End If
' no match so try again
If cellMatch Is Nothing Then
chances = chances - 1
If chances < 1 Then
MsgBox "Too many tries", vbCritical, "Exiting"
Exit Sub
End If
MsgBox sProduct & " NOT FOUND - " & chances & " tries left", vbExclamation, "Error"
GoTo LOOP1
End If
LOOP2:
iRowno = cellMatch.Row
If DBUG Then Debug.Print wsMatch.Name & " Row = " & iRowno
' determine column
With wsMatch
iColno = .Cells(iRowno, Columns.count).End(xlToLeft).Column + 1
If iColno < YR1COL Then iColno = YR1COL ' start in E
End With
wsMatch.Activate
wsMatch.Cells(iRowno, iColno).Select
If DBUG Then
wsMatch.Cells(iRowno, iColno).Interior.ColorIndex = 6 ' yellow
Debug.Print "Column = " & iColno
End If
If DBUG Then MsgBox "Target cell " & wsMatch.Name & " Row " & iRowno & " Col " & iColno, vbInformation
chances = 3
LOOP3: ' get valid QU
iQu = Application.InputBox(Title:="Input Quarter", prompt:="Test Qu (1-4) for " & sProduct, Type:=1) ' type 1 number
If iQu = 0 Then
GoTo LOOP1
ElseIf iQu > 4 Then
chances = chances - 1
If chances < 1 Then
MsgBox "Too many tries", vbExclamation, "Error"
Exit Sub
End If
MsgBox iQu & " NOT VALID - " & chances & " tries left", vbExclamation, "Error"
GoTo LOOP3
End If
' Update sheet
wsMatch.Cells(iRowno, iColno) = iQu
If DBUG Then wsMatch.Cells(iRowno, iColno).Interior.ColorIndex = 4 ' green
MsgBox "Product=" & sProduct & vbCr _
& wsMatch.Name & " Row=" & iRowno & " Col=" & iColno & " Qu=" & iQu, vbInformation, "Updated"
GoTo LOOP1 ' next product
End Sub
I have this macro to replace special characters in any sheet in my workbook.
It gets rid of these characters: ! # # $ % ^ & () /
Sub Macro3()
Dim splChars As String
Dim ch As Variant
Dim splCharArray() As String
splChars = "! # # $ % ^ & () /" splCharArray = Split(splChars, " ")
For Each ch In splCharArray
Cells.Replace What:="~" & ch, Replacement:="", LookAt:=xlPart, SearchOrder:= _
xlByRows, MatchCase:=True
Next ch
End Sub
I need a second macro which would do Cells.Find for every cell in every worksheet then create a new sheet to list all cell addresses and special characters found.
On the web I found:
Public Sub SearchForText()
Dim rngSearchRange As Range
Dim vntTextToFind As Variant
Dim strFirstAddr As String
Dim lngMatches As Long
Dim rngFound As Range
On Error GoTo ErrHandler
vntTextToFind = Application.InputBox( _
Prompt:="Enter text to find:", _
Default:="Search...", _
Type:=2 _
)
If VarType(vntTextToFind) = vbBoolean Then Exit Sub
On Error Resume Next
Set rngSearchRange = Application.InputBox( _
Prompt:="Enter range for search:", _
Default:=ActiveCell.Parent.UsedRange.Address, _
Type:=8 _
)
On Error GoTo ErrHandler
If rngSearchRange Is Nothing Then Exit Sub
Set rngFound = rngSearchRange.Find( _
What:=CStr(vntTextToFind), _
LookIn:=xlValues, _
LookAt:=xlPart _
)
If rngFound Is Nothing Then
MsgBox "No matches were found.", vbInformation
Else
With ThisWorkbook.Sheets.Add
With .Range("A1:B1")
.Value = Array("Cell", "Value")
.Font.Bold = True
End With
strFirstAddr = rngFound.Address
Do
lngMatches = lngMatches + 1
.Cells(lngMatches + 1, "A").Value = rngFound.Parent.Name & "!" _
& rngFound.Address(0, 0)
.Cells(lngMatches + 1, "B").Value = rngFound.Value
Set rngFound = rngSearchRange.FindNext(rngFound)
Loop Until (rngFound.Address = strFirstAddr)
.Columns("A:B").AutoFit
End With
End If
Exit Sub
ErrHandler:
MsgBox Err.Description, vbExclamation
End Sub
This code works. My problem is, I need to set a range in which it searches every time and it can only be one sheet, so essentially if I have 10 sheets I need to run this macro 10 times to get the desired result.
I would like to search for each character in every worksheet of my workbook, then create a new sheet and return the address of every cell in an entire workbook which contains any of my declared characters.
I thought I could declare new variable ws as worksheet and loop through all worksheets with the same range selected using for each.
Try this. You just need another loop for the worksheets, and a loop for the Find.
This code doesn't do any replacing.
Sub Macro3()
Dim splChars As String
Dim ch As Variant
Dim splCharArray() As String
Dim r As Range, s As String
Dim ws As Worksheet
splChars = "! # # $ % ^ & () /"
splCharArray = Split(splChars, " ")
Sheets.Add().Name = "Errors" 'to list characters and location
For Each ch In splCharArray
For Each ws In Worksheets
If ws.Name <> "Errors" Then
Set r = ws.Cells.Find(What:=ch, Lookat:=xlPart, SearchOrder:=xlByRows, MatchCase:=True, SearchFormat:=False)
If Not r Is Nothing Then
s = r.Address
Do
Sheets("Errors").Range("A" & Rows.Count).End(xlUp)(2) = ch 'character
Sheets("Errors").Range("B" & Rows.Count).End(xlUp)(2) = r.Address(external:=True)
Set r = ws.Cells.FindNext(r)
Loop Until r.Address = s 'loop until we are back to the first found cell
End If
End If
Next ws
Next ch
End Sub