First iteration jumping four rows instead of the expected one row - excel

Why is my first iteration in Sub throughCols that is intended to move one row down each time jumping four rows?
Option Explicit
Dim txt As String
Dim i As Long
Dim strTest As String
Dim strArray() As String
Dim lCaseOn As Boolean
Dim firstRow As Long, startIt As Long
Dim thisCell As Range
Dim lastRow As Long
Dim resetAddress As Range
Sub throughCols()
' Dim thisCell As Range
' get start and end of column data
' NB sheet name is hard coded twice
Call dataRange
startIt = firstRow + 1
For i = 1 To 8 Step 1
' after testing use startIt To lastRow Step 1
' by using activeCell I dont have to pass range through to the sub
Sheets("test").Range("B" & i).Select
MsgBox "this is itteration " & i & " which will output to " & ActiveCell.Offset(0, 2).Address
Call arrayManip
Call cleanTxt(txt)
Next i
End Sub
Sub arrayManip()
' clear out all data
Erase strArray
txt = ""
'set default case
lCaseOn = False
' string into an array using a " " separator
strTest = WorksheetFunction.Proper(ActiveCell.Value)
strTest = Replace(strTest, "-", " - ")
strTest = Replace(strTest, "‘", " ‘ ")
strArray = Split(strTest, " ")
' itterate through array looking to make text formats
For i = LBound(strArray) To UBound(strArray)
If strArray(i) = "-" Then
lCaseOn = True
GoTo NextIteration
End If
If strArray(i) = "‘" Then
lCaseOn = True
GoTo NextIteration
End If
If lCaseOn Then
strArray(i) = LCase(strArray(i))
lCaseOn = False
NextIteration:
End If
Next
End Sub
Function cleanTxt(txt)
' loop through the array to build up a text string
For i = LBound(strArray) To UBound(strArray)
txt = txt & strArray(i) & " "
Next i
' remove the space
txt = Trim(Replace(txt, " - ", "-"))
txt = Trim(Replace(txt, " ‘ ", "‘"))
' MsgBox "active cell is " & activeCell.Address
ActiveCell.Offset(0, 2).Select: ActiveCell.Value = txt
' MsgBox "final output would be " & txt & " to " & activeCell.Address
' this is a thumb suck to attempt to reset the active cell to the itteration address that started it
ActiveCell.Offset(0, -2).Select
MsgBox "next itteration should start with active cell set as " & ActiveCell.Address
End Function
Sub dataRange()
With Sheets("test").Columns("B")
If WorksheetFunction.CountA(.Cells) = 0 Then '<--| if no data whatever
MsgBox "Sorry: no data"
Else
With .SpecialCells(xlCellTypeConstants) '<--| reference its cells with constant (i.e, not derived from formulas) values)
firstRow = .Areas(1).Row
lastRow = .Areas(.Areas.Count).Cells(.Areas(.Areas.Count).Rows.Count).Row
End With
' MsgBox "the first row is " & firstRow
' MsgBox "last row is " & lastRow
End If
End With
End Sub

You are declaring your i variable at module scope, which makes it accessible everywhere within the module; it's modified when you call arrayManip and the value changes.
If you declare a local ind variable inside this routine it won't happen, because the variable will only be accessible to the scope it's declared in. Try the code below:
Sub throughCols()
' Dim thisCell As Range
Dim ind As Long '<-- DECLARE local variable
' get start and end of column data
' NB sheet name is hard coded twice
Call dataRange
startIt = firstRow + 1
' ===== loop on ind and not i (changes when you call arrayManip) ====
For ind = 1 To 8 ' Step 1 <-- actually not needed, that's the default increment value
' after testing use startIt To lastRow Step 1
' by using activeCell I dont have to pass range through to the sub
Sheets("test").Range("B" & ind).Select
MsgBox "this is itteration " & ind & " which will output to " & ActiveCell.Offset(0, 2).Address
Call arrayManip
Call cleanTxt(txt)
Next ind
End Sub

Related

Combine Multiple MsgBox to one

I am trying to combine multiple msgbox but i couldnot figure out.
Here is my Code:
If InStr(ThisWorkbook.Worksheets("DailyReport").Range("F8").Value, "DCT") > 0 Then
If IsEmpty(Sheet2.Range("G34").Value) Then
MsgBox ("The Following Test is not Performed " & Sheet2.Range("E34").Value)
End If
If IsEmpty(Sheet2.Range("G35").Value) Then
MsgBox ("The Following Test is not Performed " & Sheet2.Range("E35").Value)
End If
If IsEmpty(Sheet2.Range("G36").Value) Then
MsgBox ("The Following Test is not Performed " & Sheet2.Range("E36").Value)
End If
End If
I want to search for word DCT in Cell F8 of Worksheets DailyReport and if it exist then I want to look at multiple cell like G34,G35,G36.... and if these cell are empty then display msgbox saying "The following Test is Not performed: E34,E35,E36...."
Let's Say if G34 and G35 is Empty then the msg box should display
The following Test is not Performed:
Cell value in E34
Cell Value in E35
Msgbox Should have continue and Cancel button
If User hit Continue Then Continue the sub
If user Hit Cancel then Exit the sub
Return Combined Messages in a Message Box
Sub CombineMessages()
Dim CheckCells() As Variant: CheckCells = Array("G34", "G35", "G36")
Dim ValueCells() As Variant: ValueCells = Array("E34", "E35", "E36")
Dim CheckString As String
CheckString = CStr(ThisWorkbook.Worksheets("DailyReport").Range("F8").Value)
Dim UntestedCount As Long, MsgString As String
If InStr(CheckString, "DCT") > 0 Then
Dim n As Long
For n = LBound(CheckCells) To UBound(CheckCells)
If IsEmpty(Sheet2.Range(CheckCells(n))) Then
MsgString = MsgString & vbLf & " " _
& CStr(Sheet2.Range(ValueCells(n)).Value)
UntestedCount = UntestedCount + 1
End If
Next n
End If
If UntestedCount > 0 Then
MsgString = "The following test" _
& IIf(UntestedCount = 1, " is", "s are") & " not performed:" _
& vbLf & MsgString & vbLf & vbLf & "Do you want to continue?"
Dim Msg As Long: Msg = MsgBox(MsgString, vbQuestion + vbYesNo)
If Msg = vbNo Then Exit Sub
End If
MsgBox "Continuing...", vbInformation
End Sub
I want to look at multiple cell like G34,G35,G36....
if these cell are empty then display msgbox saying "The following Test is Not performed: E34,E35,E36...."
G34,G35,G36.... Looks like this range is dynamic? Or will it always be these 3? And if it is dynamic then how are you deciding the range. For example why G34 and not G1? Or till where do you want to check? Till last cell in G? All this will decide how you write a concise vba code. I am going to assume that you want to check till last cell in column G. In case it is say from G34 to say G60(just an example), then change the For Next Loop from For i = 34 To lRow to For i = 34 To 60
Is this what you are trying? (UNTESTED)
Option Explicit
Sub Sample()
Dim i As Long
Dim lRow As Long
Dim CellAddress As String
If InStr(ThisWorkbook.Worksheets("DailyReport").Range("F8").Value, "DCT") > 0 Then
With Sheet2
'~~> Find last row in Col G
lRow = .Range("G" & .Rows.Count).End(xlUp).Row
'~~> Check the range for blank cells
For i = 34 To lRow
If Len(Trim(.Range("G" & i).Value2)) = 0 Then
CellAddress = CellAddress & "," & "E" & i
End If
Next i
End With
'~~> Check if any addresses were found
If CellAddress <> "" Then
CellAddress = Mid(CellAddress, 2)
Dim ret As Integer
'~~> Ask user. There is no CONTINUE button. Use YES/NO
ret = MsgBox("The following Test is Not performed:" & _
vbNewLine & CellAddress & vbNewLine & _
"Would you like to continue?", vbYesNo)
If ret = vbYes Then
'~~> Do what you want
Else
'~~> You may not need the else/exit sub part
'~~> Depending on what you want to do
Exit Sub
End If
'
'
'~~> Rest of the code
'
'
End If
End If
End Sub

InStr in Array not populating value if found

I've written the below code to search for a value(Supplier Name) in sheet "Fusion" Column H in sheet "CX" column D. I'm also doing a check the other way around so if the same value(Supplier Name) in sheet CX is in sheet "Fusion". I'm not looking for an Exact match hence the use of Instr and doing the comparison both ways as i'm not sure how a user has entered the information in either sheet.
The data type in either cell should be text.
If a match is found then in the last column of sheet "CX" it should just populate either "Supplier Found" or "Supplier Not Found"
Currently it's not populating the last column with any data but the Macro isn't erroring at any point.
I've tried adding msgboxes and "Here" and "Here3" are being triggered but it doesn't seem to be hitting the section of code that is "Here2" so I think it's there that's causing the issue but not sure how to resolve it.
Screenshot of my Data is :CX Sheet
Fusion Sheet
Any help would be greatly appreciated.
Option Explicit
Sub CompareCXFusion()
Dim CX As Worksheet
Dim Fusion As Worksheet
Dim strTemp as string
Dim strCheck as string
Dim i As Long, J As Long
Dim CXArr As Variant
Dim FusionArr As Variant
Dim match As Boolean
Dim CXRng As Range
Dim FusionRng As Range
Set CX = ActiveWorkbook.Sheets("CX")
Set Fusion = ActiveWorkbook.Sheets("Fusion")
Set CXRng = CX.Range("A2", CX.Cells(Rows.Count, "A").End(xlUp).Offset(0, 6))
Set FusionRng = Fusion.Range("A2", Fusion.Cells(Rows.Count, "A").End(xlUp).Offset(0, 9))
CXArr = CXRng.Value2
FusionArr = FusionRng.Value2
strTemp = lcase(trim(FusionArr(J, 7)))
strCheck = lcase(trim(CXArr(i, 3)))
For i = 1 To UBound(CXArr)
Match = False
For J = 1 To UBound(FusionArr)
MsgBox "Here"
If (Instr(strTemp, strCheck) > 0) OR (InStr(strCheck, strTemp) > 0) Then
MsgBox"Here2"
CXArr(i, 6) = "Supplier Found"
Else
Msgbox"Here3"
CXArr(i, 6) = "Supplier not found"
End If
Next J
Next i
End Sub
The expected output i'd expect is: If in Column H of Fusion the Supplier Name is "Supplier A" and the value in Column D of sheet "CX" is "Supplier A LTD" then i'd expect it to populate column G in sheet CX with "Supplier Found" due to it being found in the string.
If you need any more info please let me know.
I don't know how to correctly insert examples of my data else I would have
Option Explicit
Sub CompareCXFusion()
Dim CX As Worksheet
Dim Fusion As Worksheet
Dim i As Long, J As Long, lastRowCX As Long, lastRowFU As Long
Dim CXText As String, FusionText As String
Dim match As Boolean
Dim CXRng As Range, FusionRng As Range
Set CX = ActiveWorkbook.Sheets("CX")
Set Fusion = ActiveWorkbook.Sheets("Fusion")
lastRowCX = CX.Range("D1").SpecialCells(xlCellTypeLastCell).Row - 1
lastRowFU = Fusion.Range("H1").SpecialCells(xlCellTypeLastCell).Row - 1
Set CXRng = CX.Range("D1:D" & lastRowCX)
Set FusionRng = Fusion.Range("H1:H" & lastRowFU)
For i = 1 To lastRowCX
match = False
For J = 1 To lastRowFU
'Debug.Print "Here"
FusionText = FusionRng.Range("A1").Offset(J, 0).Value
CXText = CXRng.Range("A1").Offset(i, 0).Value
If FusionText <> "" And CXText <> "" Then
If InStr(FusionText, CXText) Or InStr(CXText, FusionText) Then
'Debug.Print "Here2"
match = True
End If
End If
Next J
'Result goes to column G of CX range:
If match Then
CXRng.Range("A1").Offset(i, 3).Value = "Supplier found" ' "Supplier found - " & i & " - " & CXRng.Range("A1").Offset(i, 0).Address & " - " & CXRng.Range("A1").Offset(i, 3).Address
Else
CXRng.Range("A1").Offset(i, 3).Value = "Supplier NOT found" '"Supplier NOT found - " & i & " - " & CXRng.Range("A1").Offset(i, 0).Address & " - " & CXRng.Range("A1").Offset(i, 3).Address
End If
Next i
End Sub
You need to make sure to check for case sensitivity:
Dim strTemp as string
Dim strCheck as string
'Inside for I loop
'Inside for j Loop
strTemp = lcase(trim(FusionArr(J, 7)))
strCheck = lcase(trim(CXArr(i, 3)))
If (Instr(strTemp, strCheck) > 0) OR (InStr(strCheck, strTemp) > 0) Then
'...
End If
'end for j
'end for i

Increase cell value that contains number and text VBA

I have tried this code which works fine for a cell that only contain number:
Sub IncreaseCellValue()
'Add 1 to the existing cell value
Range("A1").Value = Range("A1") + 1
End Sub
How can I do something similar if the cell has text and a number. For example, I have "Apple 1" and I want to "increase" the cell text to "Apple 2" and next time I run the macro I want "Apple 3".
Here's another way you could solve this problem:
Sub IncreaseCellValue()
Dim value As Variant
'Add 1 to the existing cell value
If IsNumeric(Range("A1").value) Then
Range("A1").value = Range("A1") + 1
Else
value = Split(Range("A1").value, " ")
Range("A1").value = value(0) & " " & (CInt(value(1)) + 1)
End If
End Sub
It will cover the 2 cases you presented in your question but not every scenario you could throw at it.
Try using the following function
Sub IncreaseCellValue()
'Add 1 to the existing cell value
Range("A1").Value = Replace(Range("A1").Value2, CleanString(Range("A1")), vbNullString) & CInt(CleanString(Range("A1").Value2)) + 1
End Sub
Function CleanString(strIn As String) As String
Dim objRegex
Set objRegex = CreateObject("vbscript.regexp")
With objRegex
.Global = True
.Pattern = "[^\d]+"
CleanString = .Replace(strIn, vbNullString)
End With
End Function
please check:
Option Explicit
Sub IncreaseCellValue()
'Add 1 to the existing cell value
Dim rg As Range
Set rg = Cells(Rows.Count, "A").End(xlUp)
Range("A1" & ":" & rg.Address).AutoFill Destination:=Range("A1" & ":" & rg.Offset(1, 0).Address), Type:=xlFillDefault
End Sub
Or you may try something like this...
Function GetNumber(ByVal rng As Range) As Long
Dim i As Long
For i = Len(rng.Value) To 1 Step -1
If IsNumeric(Mid(rng.Value, i, 1)) Then
GetNumber = GetNumber & Mid(rng.Value, i, 1)
Else
Exit For
End If
Next i
End Function
Sub IncrementNumber()
Dim num As Long
num = GetNumber(Range("A1"))
Range("A1").Value = Replace(Range("A1").Value, num, num + 1)
End Sub

Searching multiple tables on the same sheet with the column in varying locations and copying them to a different sheet

Hopefully the title is clear. I am trying to search through multiple tables on a single sheet. The information I am looking for is the same for all of the tables, just that the corresponding column is located in different spots (e.g. in one table the column I want to search is in I, while for another table it could be in O.) which makes it a bit more challenging for me.
I want to search through each column that has the same title (Load Number) and depending on its value, copy that entire row over to a sheet that corresponds with that value.
Below is what I have so far in VBA as well as a picture to hopefully clarify my issue.
Any help/advice is appreciated!
http://imgur.com/a/e9DyH
Sub Load_Number_Finder()
Dim ws As Worksheet
Dim i As Integer
Dim j As Integer
j = 1
Set ws = Sheets.Add(After:=Sheets("Master"))
ws.Name = ("Test Load " & j)
i = 1
Sheets("Master").Select
For Each cell In Sheets("Master").Range("M:M")
If cell.Value = "1" Then
j = 1
'Set WS = Sheets.Add(After:=Sheets("Master"))
'WS.Name = ("Test Load " & j)
matchRow = cell.Row
Rows(matchRow & ":" & matchRow).Select
Selection.Copy
Sheets("Test Load " & j).Select
ActiveSheet.Rows(i).Select
ActiveSheet.Paste
Sheets("Master").Select
i = i + 1
ElseIf cell.Value = "" Then
' 2, 3, 4, 5, cases
Else
' Something needs to go here to catch when it doesnt have a load number on it yet
End If
' Err_Execute:
' MsgBox "An error occurred."
Next
End Sub
Try this function. This should work for you. Let me know what the results are with your sheet. I made a mock up sheet and tested it, it worked. I can make changes if this is not exactly what you are looking for.
Option Explicit
Sub copyPaste()
Dim rowCount, row_ix, temp, i As Integer
Dim TD_COL_IX As Integer
Dim td_value As String
Dim td_values() As String
rowCount = Worksheets("Master").Cells(Rows.Count, "A").End(xlUp).Row
For row_ix = 1 To rowCount
temp = isNewTable(CInt(row_ix))
If temp > 0 Then
TD_COL_IX = temp
ElseIf TD_COL_IX > 0 Then
td_value = Worksheets("Master").Cells(row_ix, TD_COL_IX)
If Not td_value = "" Then
td_values = Split(td_value, " ")
For i = 0 To UBound(td_values)
If Not sheetExists("Test Load " & td_values(i)) Then
Sheets.Add.Name = "Test Load " & td_values(i)
End If
If Worksheets("Test Load " & td_values(i)).Cells(1, 1).Value = "" Then
Worksheets("Master").Range(Worksheets("Master").Cells(row_ix, 1), Worksheets("Master").Cells(row_ix, TD_COL_IX - 1)).Copy _
Destination:=Worksheets("Test Load " & td_values(i)).Cells(1, 1)
Else
Dim rowCount_pasteSheet As Integer
rowCount_pasteSheet = Worksheets("Test Load " & td_values(i)).Cells(Rows.Count, "A").End(xlUp).Row
Worksheets("Master").Range(Worksheets("Master").Cells(row_ix, 1), Worksheets("Master").Cells(row_ix, TD_COL_IX - 1)).Copy _
Destination:=Worksheets("Test Load " & td_values(i)).Cells(rowCount_pasteSheet + 1, 1)
End If
Next i
End If
End If
Next row_ix
End Sub
Function isNewTable(row_ix As Integer) As Integer
Dim colCount, col_ix As Integer
colCount = Worksheets("Master").Cells(row_ix, Columns.Count).End(xlToLeft).Column
For col_ix = 1 To colCount
If Not IsError(Worksheets("Master").Cells(row_ix, col_ix).Value) Then
If Worksheets("Master").Cells(row_ix, col_ix).Value = "LD #" Then
isNewTable = col_ix
Exit Function
End If
End If
Next col_ix
isNewTable = 0
End Function
' ####################################################
' sheetExists(sheetToFind As String) As Boolean
'
' Returns true if the sheet exists, False otherwise
' ####################################################
Public Function sheetExists(sheetToFind As String) As Boolean
Dim sheet As Worksheet
sheetExists = False
For Each sheet In Worksheets
If sheetToFind = sheet.Name Then
sheetExists = True
Exit Function
End If
Next sheet
End Function

VBA code only deletes row when run in debug mode

Im having trouble deleting Rows when running the code not in debug mode. I put stars next to the line giving me a problem. Works in debug mode but not normally running the code. Any help? I have tried using doevent but in the beginning of the for loop but that didnt work.
Public Sub ItemUpdate(ByVal startRow As Integer, ByVal endRow As Integer, ByVal itemCol As String, ByVal statusCol As String, ByVal manuPNCol As String)
Dim orgSheet As Worksheet
Dim commonSheet As Worksheet
Dim partDesCol As String
Dim partDes As String
Dim vendorColNumber As Integer
Dim vendorColLetter As String
Dim manuPN As String
Dim counter As Integer
Dim replaceRnge As Range
Set orgSheet = ThisWorkbook.ActiveSheet
partDesCol = FindPartDesCol()
Set commonSheet = ThisWorkbook.Worksheets("Common Equipment")
For counter = startRow To endRow
'Get part description value
partDes = Range(partDesCol & counter).Value
'Delete row of empty cells if there is any
If partDes = "" Then
'deleteing empty row
orgSheet.Rows(counter).Delete '************************** Only works in
debug mode.
endRow = endRow - 1
If counter < endRow Then
counter = counter - 1
Else
Exit For
End If
Else
manuPN = Range(manuPNCol & counter).Value
'Search for user part in common sheet
Set rangeFind = commonSheet.Range("1:200").Find(partDes, lookat:=xlWhole)
If rangeFind Is Nothing Or partDes = "" Then
Debug.Print "Part " & partDes & " not found in Common Equipment"
'MsgBox "Part " & partDes & " not found in Common Equipment"
'Now check if manuPN is in common equipment
Set rangeFind = commonSheet.Range("1:200").Find(manuPN, lookat:=xlWhole)
If rangeFind Is Nothing Or partDes = "" Then
Debug.Print "PartNumber " & manuPN & " not found in Common Equipment"
'Now check if vendor value of item is empty
'Get vendor col
vendorCol = FindSearchCol()
If orgSheet.Range(vendorCol & counter).Value = "" Then
'Copy and paste manufact. data to vendor
'converting from letter column to number and visa versa
vendorColNumber = Range(vendorCol & 1).Column
ManuColTemp = vendorColNumber - 2
ManuPNColTemp = vendorColNumber - 1
VendorPNColTemp = vendorColNumber + 1
ManuCol = Split(Cells(1, ManuColTemp).Address(True, False), "$")(0)
manuPNCol = Split(Cells(1, ManuPNColTemp).Address(True, False), "$")(0)
VendorPNCol = Split(Cells(1, VendorPNColTemp).Address(True, False), "$")
(0)
orgSheet.Range(ManuCol & counter & ":" & manuPNCol & counter).Copy Range(vendorCol & counter & ":" & VendorPNCol & counter)
End If
Else
'Copy new data from common equipment and paste in place of old data
'Get value of status
If statusCol <> "error" Then
orderStatus = orgSheet.Range(statusCol & counter).Value
End If
commonSheet.Rows(rangeFind.Row).EntireRow.Copy
orgSheet.Range(itemCol & counter).PasteSpecial xlPasteValues
If statusCol <> "error" Then
orgSheet.Range(statusCol & counter).Value = orderStatus
End If
End If
Else
'Copy new data from common equipment and paste in place of old data
'Get value of status
If statusCol <> "error" Then
orderStatus = orgSheet.Range(statusCol & counter).Value
End If
commonSheet.Rows(rangeFind.Row).EntireRow.Copy
orgSheet.Range(itemCol & counter).PasteSpecial xlPasteValues
If statusCol <> "error" Then
orgSheet.Range(statusCol & counter).Value = orderStatus
End If
End If
End If
Next counter
'call renumber item numbers
Call NumberItems(0, 0, 0, False)
End Sub
Most likely, you need to step backwards through your range. When you step forward, as you are doing, the counter will skip a row whenever you delete a row:
For counter = startRow To endRow
Change to
For counter = endRow To startRow Step -1
Also, you should declare endRow and startRow as data type Long. The range of Integer will not cover all the rows in an Excel worksheet; and also VBA is said to convert Integers to Longs when doing the math anyway.

Resources