code for extracting and loading value to the userform - excel

I'm trying to write a code that will extract value from the database where it is stored, load the value in the user form for editing purposes. The values from the database are stored as a " multi-line " cell entry. and here's the code im stuck on.
Private Sub cmd_Continue_Click()
Dim TargetRow As Integer
TargetRow = Application.WorksheetFunction.Match(ColumnC_Menu, Sheets("Data").Range("Dyn_Business_Name_Website"), 0)
MsgBox (TargetRow)
End Sub
Here's the Code from the main Userform:
Private Sub cmd_Submit_Click()
'When we click Submit button'
Dim TargetRow As Integer 'variable for position control
Dim BusinessName As String
TargetRow = Sheets("Engine").Range("B3").Value + 1 'make variable equal to COUNTA formula on worksheet +1
BusinessName = Txt_BusinessName & vbNewLine & Txt_Website
If Application.WorksheetFunction.CountIfs(Sheets("Data").Range("Dyn_Business_Name_Website"), BusinessName) > 0 Then
MsgBox ("Name Already Exists"), 0, "Check!"
Exit Sub
End If
'Begin Input into the data'
Sheets("Data").Range("Data_Start").Offset(TargetRow, 0).Value = Txt_Rank
Sheets("Data").Range("Data_Start").Offset(TargetRow, 1).Value = Txt_BusinessName & vbNewLine & Txt_Website
Sheets("Data").Range("Data_Start").Offset(TargetRow, 2).Value = Txt_Address & vbNewLine & Txt_Phone

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

populate worksheet from excel table

I have been asked to remake the excel workbook to index where we keep the items.
I have an excel sheet with a table ( excel table) that contains the information.
If the there the value in column 6 ="10" then that means the item is in box 10.
then I need to get the right shelve, this is found by the numbers in column 7 (shelve) and 8 (rack). subsequently the information about the item has to be put in another sheet which gives a visual representation of the box.
I am struggling to get the desired result, does anyone have some suggestions?
Sub box()
Dim rng As Range
For x = 1 To 12
Set rng = Sheets("Register").ListObject("Table1").Range(x, 8).Value
If Range("Table1").ListObject.Range(x, 6).Value = "10" Then
If Range("Table1").ListObject.Range(x, 7).Value = "1" Then
Sheets("box 10").Range(3, rng).Value = Range("Table1").ListObject.Range(x, 2).Value & Range("Table1").ListObject.Range(x, 3)
End If
End If
Next x
End Sub
Please, try the next code. It will iterate in the table DataBodyRange and build a sheet name obtained by concatenation of "Box " with value in table column 6 (in your workbook). If such a sheet does not exist, a warning message is sent and stops the code:
Option Explicit
Sub box()
Dim boxVal As String, tbl As ListObject, shBox As Worksheet, rngRef As Range, x As Long
Dim shelvNo As Long, rackNo As Long
Dim iRow As Long: iRow = 1 ' row where "rack" exist
Dim iCol As Long: iCol = 1 'column letter where "rack" exists (C:C)
Set tbl = Sheets("Register").ListObjects("Table1")
For x = 1 To tbl.DataBodyRange.Rows.Count 'on the frist row there are ABC, ABC etc.
If tbl.DataBodyRange.Cells(x, 1) = "" Then Exit For
boxVal = tbl.DataBodyRange.Cells(x, 6).Value
On Error Resume Next
Set shBox = Sheets("Box " & boxVal) 'set the sheet of the appropriate box 'set the sheet of the appropriate box
If Err.Number <> 0 Then
Err.Clear: On Error GoTo 0
MsgBox "No sheet named """ & "box " & tbl.DataBodyRange.Cells(x, 6).Value & """ exists" & vbCrLf & _
"Please, create it and run the code again!": Exit Sub
End If
On Error GoTo 0
Set rngRef = shBox.Cells(iRow, iCol)
shelvNo = iRow + 1 + tbl.DataBodyRange.Cells(x, 7).Value
rackNo = iCol + tbl.DataBodyRange.Cells(x, 8).Value - 1
rngRef.Offset(shelvNo, rackNo).Value = tbl.DataBodyRange.Cells(x, 2).Value & " " & tbl.DataBodyRange.Cells(x, 3).Value
Next x
MsgBox "Ready..."
End Sub

VBA change state of toggle button

I have a document where you can move or copy a row, there is a "move" and "copy" button, both are toggle buttons
'VARIABLES
Const sSTARTROW As String = "A"
Const sENDROW As String = "O"
Const sMOVEBUTTON As String = "Move line"
Const sCOPYBUTTON As String = "Copy line"
Dim sClipboard() As String
Dim iRowNumberBackup As Integer
Private Sub MoveButton_Click()
Dim sRange As String
Dim rDataRange As Range
Select Case MoveButton.Value
'pushed
Case True
GetData ActiveCell.Row, False
'released
Case False
DropData ActiveCell.Row
End Select
End Sub
Private Sub CopyButton_Click()
Select Case CopyButton.Value
'pushed
Case True
GetData ActiveCell.Row, True
'released
Case False
DropData ActiveCell.Row
End Select
End Sub
And these are the functions.
Function GetData(iRowNumber As Integer, bCopy As Boolean)
Dim cell As Range
'set the row number were data was taken from to set back in case of emergency
iRowNumberBackup = iRowNumber
'create the range that needs to be moved
sRange = sSTARTROW & iRowNumber & ":" & sENDROW & iRowNumber
'copy value into dynamic range
Set rDataRange = Range(sRange)
'if the line is empty stop everything
If rDataRange(1, 1) = 0 Then
MsgBox ("empty line")
Exit Function
End If
'define array size depending the size of range
ReDim sClipboard(rDataRange.Columns.Count)
'put the value of range into the array
Dim i As Integer: i = 0
For Each cell In rDataRange.Cells
sClipboard(i) = cell.Value
i = i + 1
Next cell
'check if it's copy or move
Select Case bCopy
Case True
'change button description
CopyButton.Caption = sClipboard(0) & " - " & sClipboard(1) & " (" & sClipboard(2) & ")"
Case False
'remove data that was placed in the array
Range(sRange).ClearContents
'change button description
MoveButton.Caption = sClipboard(0) & " - " & sClipboard(1) & " (" & sClipboard(2) & ")"
End Select
End Function
.
Function DropData(iRowNumber As Integer)
Dim cell As Range
'create the range that needs to be moved
sRange = sSTARTROW & iRowNumber & ":" & sENDROW & iRowNumber
'set the new range
Set rDataRange = Range(sRange)
'if the line is already with data set back in previous row where it was copied & stop everything
If rDataRange(1, 1) <> 0 Then
MsgBox ("Data already in this line")
DropData (iRowNumberBackup)
Exit Function
End If
'copy value from the array into the selected range
Dim i As Integer: i = 0
For Each cell In rDataRange.Cells
cell.Value = sClipboard(i)
i = i + 1
Next cell
'empty array
Erase sClipboard
'change button description
MoveButton.Caption = sMOVEBUTTON
CopyButton.Caption = sCOPYBUTTON
End Function
I would like to avoid copying / moving empty lines, as well as not overwriting a line with data yet (or at least give a warning). See msgbox in the code.
What property can I use to change it so after the first click, the button goes back into the "released" state ? When I do just "value = false" the click event is triggered again.
If a "simple" button instead of a Active X toggle button is a solution, this solution would also be great. It's just for usability it took this toggle button.
Thanks for your input.
PS: also I would prefer to pass the button itself to the formula instead of a boolean where I have to do a check.
Meanwhile I found a (temporary?) solution, to call again the click event of the button, this way the button is back in "released" mode. Here's (for one button) the code:
Sub MoveButton_Click()
'check for avoiding endless loop
If Not bEmptyline Then
Dim sRange As String
Dim rDataRange As Range
DisableOtherButton (False)
Select Case MoveButton.Value
'clicked
Case True
GetData ActiveCell.Row, False
'released
Case False
DropData ActiveCell.Row
End Select
End If
End Sub
.
Function GetData(iRowNumber As Integer, bCopy As Boolean)
Dim cell As Range
'set the row number were data was taken from to set back in case of emergency
iRowNumberBackup = iRowNumber
'create the range that needs to be moved
sRange = sSTARTROW & iRowNumber & ":" & sENDROW & iRowNumber
'copy value into dynamic range
Set rDataRange = Range(sRange)
'if the line is empty stop everything
If rDataRange(1, 1) = 0 Then
EmptyLine (bCopy)
Exit Function
End If
'define array size depending the size of range
ReDim sClipboard(rDataRange.Columns.Count)
'put the value of range into the array
Dim i As Integer: i = 0
For Each cell In rDataRange.Cells
sClipboard(i) = cell.Value
i = i + 1
Next cell
'check if it's copy or move
Select Case bCopy
Case True
'change button description
CopyButton.Caption = sClipboard(0) & " - " & sClipboard(1) & " (" & sClipboard(2) & ")"
Case False
'remove data that was placed in the array
Range(sRange).ClearContents
'change button description
MoveButton.Caption = sClipboard(0) & " - " & sClipboard(1) & " (" & sClipboard(2) & ")"
End Select
End Function
.
Function EmptyLine(bCopy As Boolean)
whatever = MsgBox("Empty row selected.", vbInformation)
'change empty line to avoid endless loop (for every time click event)
bEmptyline = True
'recall click to set button back to standard state (not clicked but released), BETTER SOLUTION ???
Select Case bCopy
'coming from the copy button
Case True
CopyButton.Value = Not CopyButton.Value
Sheet1.CopyButton_Click
'coming from the move button
Case False
MoveButton.Value = Not MoveButton.Value
Sheet1.MoveButton_Click
End Select
'set back to false for next time
bEmptyline = False
End Function

Macro to Count Filter Distinct unique Value

I Have Table like this, where i have to use macro because my table always change Every day (SSAS)
so i have use macro to filter automatically,
I am able to sum Amount based on same Vendorname, PONuber and Date on Column E (Subtotal).
and then filter to show Subtotal AMount >500
I want to show only row >500 (Column E), and pop up message to count PONumber (Column B) how many Unique PO Number (Only Visible Row to count)
i've been stuck how to count only Visible Unique PO Number and show it on Pop Up message
this is my Macro
Sub FilterCOunt_Click()
Dim Condition As Variant
Dim AVal As Variant
Dim LastRow As Long
Dim Hide, popup As Long
Dim message As String
Dim sht As Worksheet
'----------------------------
Dim dictionary As Object
Set dictionary = CreateObject("scripting.dictionary")
'---------------------------
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.AskToUpdateLinks = False
Application.DisplayAlerts = False
Application.Calculation = xlAutomatic
Application.ScreenUpdating = False
Application.StatusBar = False
'------------------
Columns.EntireColumn.Hidden = False
Rows.EntireRow.Hidden = False
Columns("E:Z").EntireColumn.Delete
Range("E:Z").EntireColumn.Insert
Range("E1").Value = "Sub Total >500 "
Set sht = ActiveSheet
LastRow = sht.Range("B" & Rows.Count).End(xlUp).Row
'-------------------
For i = 2 To LastRow ' with last row count =SUMIFS(I:I,A:A,A8,B:B,B8,C:C,C8)
AVal = "A" & i
BVal = "B" & i
CVal = "C" & i
Worksheets("Sheet3").Range("E" & i).Formula = "=SUMIFS(D:D,A:A," & AVal & ",B:B," & BVal & ",C:C," & CVal & ")"
Next i
With sht.Range("E1:E" & LastRow)
.AutoFilter
.AutoFilter field:=1, Criteria1:=">=500"
End With
'----------Count Pop UP
Dim CountPO As Long
Range("G1").FormulaArray = "=SUM(IF(FREQUENCY(IF(SUBTOTAL(3,OFFSET(B2,ROW(B2:B22)-ROW(B2),1)),IF(B2:B22<>"",MATCH(""&B2:B22,B2:B22&"",0))),ROW(B2:B22)- ROW(B2)+1),1))"
MsgBox "We Found " & CountPO & " PO Open(s)", _
vbInformation, "PO Found"
End Sub
and this is the formula to count it
{=SUM(IF(FREQUENCY(IF(SUBTOTAL(3,OFFSET(B2,ROW(B2:B22)-ROW(B2),1)),IF(B2:B22<>"",MATCH("~"&B2:B22,B2:B22&"",0))),ROW(B2:B22)-ROW(B2)+1),1))}
If you are pulling from a Database via SSAS you can use Power Query to link to your SSAS DataModel to Excel and you can insert a Calculated Measure in Dax from there with DistinctCount.
Count:=Calculate(DistinctCount(TableName[PONumber]),TableName[Amount]>500)
Alternatively if you want total insights on your specified issue you can add a measured column and then you can use Power Pivot to filter for your criteria live on refresh to the data model, completely negating the need for VBA entirely.
Incidentally it is pertinent to remember VBA is the sledge hammer of solutions please use the DataModel Tools before you ever think of a macro solution remember, VBA is an Application Programming Language and many IT Security Systems will disable it because it opens the system up for malware, you can literally change any file or program in VBA including calling delete system files
Meanwhile having a set DataModel in a locked file that requires user access behind LAN security is easily more secure than allowing your computer to have open programatic access.
This is an alternative formula (which doesn't require any filtering)
=SUM(--(FREQUENCY(IF(B2:B20>500,MATCH(A2:A20,A2:A20,0)),ROW(A2:A20)-ROW(A2)+1)>0))
It's an array formula so using VBA
Range("E1").FormulaArray = "=SUM(--(FREQUENCY(IF(B2:B20>500,MATCH(A2:A20,A2:A20,0)),ROW(A2:A20)-ROW(A2)+1)>0))"
A formula for your cell E2, which is not an array formula, is
=SUMPRODUCT((B2=B$2:B$23)*(A2=A$2:A$23)*(D$2:D$23))
Copy it down, as usual.
See here for why not using an array formula (if you have an alternative).
I am not certain this solves your question, as I did not fully understand it.
You can use the following code. I have implemented Collection to get the unique count.
This will count the unique rows in B column where value in E column > 500.
Private Sub GetUniqueCount() AS Variant
Dim Test As New Collection
Dim rng As Range
For i = 2 To 6 'Replace 6 with last row(without filtration)
Value = Cells(i, "B").Value
check = Contains(Test, Value)
If Cells(i, "E").Value > 500 And Not check And Len(Value) > 0 Then
Test.Add Value, CStr(Value)
End If
Next i
GetUniqueCount = Test.count
End Sub
'Function to check if the value exists in Collection or not
Public Function Contains(col As Collection, key As Variant) As Boolean
Dim obj As Variant
On Error GoTo err
Contains = True
obj = col(key)
Exit Function
err:
Contains = False
End Function
Step 1: Post my code to a new module.
Step 2: Bind you button to the macro named "filterAndCount"
Step 3: Click the buton and rejoice :-)
Code description:
1) The code loops all the rows in the table.
2) First it checks if the Sub Total is above the limit (500).
3) If equal or below it hides the row and moves on to the next row.
4) If above it checks if the value already exists in the array values above.
5) If it does not exists then the value is added to the array.
6) When all rows have been looped only rows with a Sub Total above the limit is visible.
7) Only the unique and visible PO Numbers have been added to the array.
8) The number of values in the array is dispayed in a message box.
Dim wb As Workbook
Dim ws As Worksheet
Dim i As Double
Dim n As Double
Dim subTotalLimit As Double
Dim arr() As String
Sub filterAndCount()
Set wb = ThisWorkbook
Set ws = wb.ActiveSheet
i = 2
subTotalLimit = 500
n = 0
ReDim arr(0 To 0) As String
arr(0) = 0
ws.Columns("E:Z").EntireColumn.Delete
ws.Range("E:Z").EntireColumn.Insert
ws.Range("E1").Value = "Sub Total >500 "
Do While ws.Range("B" & i) <> ""
ws.Range("E" & i).Formula = "=SUMIFS(D:D,A:A,A" & i & ",B:B,B" & i & ",C:C,C" & i & ")"
If ws.Range("E" & i) < subTotalLimit Then
ws.Range("B" & i).EntireRow.Hidden = True
Else
If Not IsNumeric(Application.Match(Range("B" & i).Text, arr(), 0)) Then
arr(n) = Range("B" & i).Value
n = UBound(arr) + 1
ReDim Preserve arr(0 To n) As String
arr(n) = 0
End If
End If
i = i + 1
Loop
MsgBox UBound(arr)
End Sub
Use 2 Dictionary Objects, one for totals and one for unique PO's
Sub filterCOunt()
Const LIMIT = 500
Dim wb As Workbook, ws As Worksheet
Dim iRow As Long, iLastRow As Long, amount As Single
Dim sVendor As String, sPO As String, msg As String, sKey As String
Dim dictPO As Object, dictTotal As Object
Set dictPO = CreateObject("Scripting.Dictionary")
Set dictTotal = CreateObject("Scripting.Dictionary")
Set wb = ThisWorkbook
Set ws = ActiveSheet
iLastRow = ws.Range("B" & Rows.Count).End(xlUp).Row
' first pass to total by po and vendor
For iRow = 2 To iLastRow
sVendor = Trim(ws.Cells(iRow, 1))
sPO = Trim(ws.Cells(iRow, 2))
amount = CSng(ws.Cells(iRow, 4))
sKey = sVendor & "_" & sPO
' sub total
If dictTotal.exists(sKey) Then
dictTotal(sKey) = dictTotal(sKey) + amount
Else
dictTotal.Add sKey, amount
End If
Next
' second pass for PO numbers
For iRow = 2 To iLastRow
sVendor = Trim(ws.Cells(iRow, 1))
sPO = Trim(ws.Cells(iRow, 2))
sKey = sVendor & "_" & sPO
' sub total
ws.Cells(iRow, 5) = dictTotal(sKey)
If dictTotal(sKey) > LIMIT Then
If Not dictPO.exists(sPO) Then
dictPO.Add sPO, iRow
End If
End If
Next
' filter
With ws.Range("E1:E" & iLastRow)
.AutoFilter
.AutoFilter field:=1, Criteria1:=">=" & LIMIT
End With
msg = "No of open PO's = " & dictPO.Count
MsgBox msg, vbInformation
End Sub
First, for your code Count Pop UP to work, let's change all from "" to """"
Second, to be able to notify a Unique PO Number and show it on Pop Up message, you must call the value received from cell G1, or, safer, use evaluate to get the result of this expression.
Your code will probably work now
'Dim CountPO As Long
Range("G1").FormulaArray = "=SUM(IF(FREQUENCY(IF(SUBTOTAL(3,OFFSET(B2,ROW(B2:B22)-ROW(B2),1)),IF(B2:B22<>"""",MATCH(""""&B2:B22,B2:B22&"""",0))),ROW(B2:B22)- ROW(B2)+1),1))"
MsgBox "We Found " & [g1].Value2 & " PO Open(s)", vbInformation, "PO Found"
however, your formula only counts all unique values including less than 500, in addition it is quite long. You can replace it using the shorter formula like the following code:
Dim formula_string As String
formula_string = "=SUMPRODUCT((B2:B22>3)*(C2:C22<>"""")/COUNTIF(B2:B22,B2:B22&""""))"
MsgBox "We Found " & Application.Evaluate(formula_string) & " PO Open(s)", vbInformation, "PO Found"
Hope it helps!

First iteration jumping four rows instead of the expected one row

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

Resources