VBA Code to link checkboxes to certain columns - excel

I have three columns E(insufficient QTY) F(Too Slow) and G(Not Listed) They all have checkboxes in them. I need to link
E to H
F to I
G to J
The following code works nicely if there was only 1 column of checkboxes but I don't know how to improve the code to run by checkboxes in a certain column. Right now it just searches the entire sheet for checkboxes and links them to the desired column.
Sub LinkChecks()
'Update 20150310
i = 2
For Each cb In ActiveSheet.CheckBoxes
cb.LinkedCell = Cells(i, "I").Address
i = i + 1
Next cb
End Sub

Edit
Ok... let's try again:
Since the Check Box object does not have cell information for the cell it's located in, we will have to use the Offset property more creatively.
Since we know there are 3 check boxes per row, we can find the total number of check boxes and divide by 3 to find out how many rows there are.
Then by setting a Range to a single cell at the top of column "E", you can use the offset property on that cell.
Assuming you placed your Check Boxes on the sheet down column "E" sequentially, and then down column "F" next, then down "G", we can reset the offsets once we get to the last row of each column. (If you place the check boxes on the sheet in row order, you'll have to invert the loop logic.) (If you placed the check boxes on randomly, you are out of luck and will have to set your linked cells manually.)
Sub LinkChecks()
Dim rng As Range
Dim strColumn As String
Dim i As Integer
Dim intCount As Integer
Dim intRowCnt As Integer
Dim intRowOffset As Integer
Dim intColumnOffset As Integer
Dim dCnt As Double
i = 1 ' Your initial row offset
intCount = 0 ' A counter for total number of check boxes
intRowCnt = 0 ' A Row counter to find last row
intRowOffset = i ' Current Row offset from initial rng cell
intColumnOffset = 3 ' Current Column Offset (3 over from first check box column)
strColumn = "E" ' Set a starting Column of your first check box
Set rng = ActiveSheet.Cells(1, strColumn) ' Set initial rng cell
' Count how many check boxes are on the active sheet
For Each cb In ActiveSheet.CheckBoxes
intCount = intCount + 1
Next cb
' Since you know you have 3 check boxes per row,
' you can divide by 3 to get your row count
dCnt = intCount / 3
' *** Put test for remainder problems here ***
For Each cb In ActiveSheet.CheckBoxes
cb.LinkedCell = rng.Offset(intRowOffset, intColumnOffset).Address
intRowOffset = intRowOffset + 1
' Increment your row count until you get to last row
intRowCnt = intRowCnt + 1
If intRowCnt >= dCnt Then
intRowCnt = 0 ' Reset you row counter
intColumnOffset = intColumnOffset + 1 ' Increment Offset to the next column
intRowOffset = i ' Reset Row offset back to top row
End If
Next cb
End Sub
As long as your check boxes were placed on the sheet down each column, the above program should find the correct Linked Cell for each box.
If they were placed in a different order, then at least this code shows you how to set an initial Range cell and how you can reference other cells with an offset.
Hopefully this code or a combination of these ideas will help you with your problem. :)

Related

How to use a for loop to count the number of zeros in each column on a worksheet in Excel VBA?

I am trying to make a sub that loops through 31 columns on one worksheet to find the number of 0's that exist in each column. Each column can have a different amount of data, up to 25,000 cells in each column. I need to take the number of 0's counted and paste it in the 47th row of each column. The data that I need to count starts in row 49 and can go to 25,049. My thought process was to count the number of rows with data instead of having VBA look through possible blank cells to save performance. When I ran the code below, it never counted more than 1 zero in each row. Most of them said there was no instances of a zero when there would be like 9 of them. I'm not sure where I'm going wrong.
Sub FindingZeros()
'________________________________________
'TO DO:
'Filter data in this workbook for 0's and
'count instances
'________________________________________
Dim zeros As Integer
Dim currcol As Integer
Dim temp As Worksheet
Set temp = Worksheets("306 Toyota 2.5L")
For currcol = 2 To 32
Dim lastrow1 As Long
lastrow1 = temp.Range(Cells(49, currcol), Cells(temp.Rows.Count, currcol)).End(xlUp).Row
zeros = Application.WorksheetFunction.CountIf(Range(Cells(49, currcol), Cells(lastrow1, currcol)), 0)
temp.Cells(47, currcol).Value = zeros
Next currcol
End Sub
The main issue you were having was identifying the last used row of a column, in this instance we do not need to know the range but just the last row, so lastrow1 only needs the last row number.
Then we do not need to set a variable of for the zeros as the value can be put directly in to the cell.
Refer to the comments:
Sub FindingZeros()
Dim currcol As Integer
Dim temp As Worksheet
Dim lastrow1 As Long
Set temp = Worksheets("306 Toyota 2.5L")
For currcol = 2 To 32
' find last used row of column
lastrow1 = Cells(temp.Rows.Count, currcol).End(xlUp).Row
' set the value of the cell to the counted zeroes.
Cells(47, currcol).Value = Application.WorksheetFunction.CountIf(Range(Cells(49, currcol), Cells(lastrow1, currcol)), 0)
Next currcol
End Sub

Finding min, max and average of a dynamic range of columns and rows VBA

I am trying to find the MIN, MAX and AVERAGE of each column (Note: number of columns varies each day). A summary table, on the next worksheet, of the MIN, MAX and AVERAGE of each column is the desired output. Each of the columns has a unique serial number (As per summary information in photo below).
Also, I am trying to find the MIN, MAX and AVERAGE of each row (Note: number of rows also varies each day). These values are desired to be listed in Columns CZ (min), DA (Max), DB(Average).
Please find my attempt below, which gave the following error:
"Run-time error '1004': Unable to get the Min property of the
WorksheetFunction class"
I have attempted this with formulas but the excel sheet slows down dramatically, so was hoping VBA would speed the processing up. I would have estimated 2000-4000 rows and up to 100 columns of temperature data.
Sub Range_End_Method()
'Finds the last non-blank cell in a single row or column
Dim Row As Long
Dim Col As Long
Dim MinValue As Integer
Dim Min_Values As Range
Dim Cycle As Integer
Dim RangeNew As Variant
'Find the last non-blank cell in column C(1)
Row = ThisWorkbook.Sheets("1. Paste Raw Data").Cells(Rows.Count, 3).End(xlUp).Row
'Find the last non-blank cell in row 9
Col = ThisWorkbook.Sheets("1. Paste Raw Data").Cells(9, Columns.Count).End(xlToLeft).Column
For i = 3 To Col
RangeNew = Range(Cells(9, i).Address, Cells(Row, i).Address).Address
MinValue = Application.WorksheetFunction.Min(RangeNew)
Cycle = 3
MinValue = Sheets("5. Summary Information").Cells((Cycle + i), i)
Next
End Sub
I don't think the code below will do what you want but it features correct syntax for setting a range and for determining the last used row and column in a worksheet. Given the correct syntax you may now be able to introduce the correct logic.
Sub Range_End_Method()
' Variatus#STO 22 Feb 2020
Dim MinValue As Integer
Dim MinRng As Range
Dim Cycle As Integer
Dim Rl As Long ' last used row
Dim Cl As Long ' last used column
Dim i As Integer
'Find the last non-blank cell in column C(1)
' rows and columns must be counted in the same sheet!
With ThisWorkbook.Sheets("1. Paste Raw Data")
Rl = .Cells(.Rows.Count, 3).End(xlUp).Row
'Find the last non-blank cell in row 9
Cl = .Cells(9, .Columns.Count).End(xlToLeft).Column
Cycle = 3
For i = 3 To Cl
Set MinRng = .Range(.Cells(9, i), .Cells(Rl, i))
Debug.Print MinRng.Address
MinValue = Application.WorksheetFunction.Min(MinRng)
Sheets("5. Summary Information").Cells((i + Cycle), i).Value = MinValue
Next i
End With
End Sub
I draw your attention to the line Debug.Print MinRng.Address which I have added to support your testing. This line will print the address of the MinRange to the Immediate window on each iteration and you can see if it is what you intend.
Note also that I have reversed your code for writing the MinValue to sheet 5. It appeared more logical to me this way but I doubt that the coordinates of the target cell are specified correctly.

Search for string to move one row lower

Sheet contains commission data for employees.
Data is dumped out of Accounting system each week.
Need to move a cell value "Totals" down 1 row to align with the relevant data.
Have tried to search for the string "Totals" then cut and paste 1 row lower.
The string is in col-A. The dataset size and content rows is variable each week but the target string is always in col-A and needs to drop down 1 row, probably with an offset (1, 0) style of command?
Dim m As Integer
m = 2
Do Until m = 300 'this is set to cover the expected occurrences
On Error Resume Next
Range(A1, A300).Cells("m", 0).Find(What:="Totals").Offset(1, 0) = "TOTALS"
m = m + 1
On Error GoTo 0
Loop
Getting no error messages but no results either!
Forget the 'Cut & Paste'. Simply insert a new row at the 'Totals' row.
dim m as variant
m = application.match("totals", range("A:A"), 0)
if not iserror(m) then
rows(m).insert
end if
(and YES you should qualify your parent worksheets!)
So this is what I think you are after. Define the range where the "Totals" lie - assuming they are in a Row? See below code.
Sub LoopTotals()
Dim cell As Range
Dim myRange As Range
'set the range
Set myRange = Sheet1.Range("A1:AA1")
'loop through range
For Each cell In myRange
'check if text is "Totals"
If Trim(cell.Text) = "Totals" Then
'set the new "Totals" 1 row lower
cell.Offset(1, 0).Value = "Totals"
'delete the old string value
cell.ClearContents
End If
Next
End Sub
Additionally, if the "Totals" are pulled in differently each time from the accounting software then you can run a search to find the "Totals" and then you can reference that row number for you range.

Excel Find and replace a single match value with multiple new values

I have 2 excel sheets, where I would like to find and replace values, however I would like to have multiple replace values take the spot of one match value.
Sheet 1: Sheet 2:
Match Value Match Value New Value
28045000 28045000 28051560
39162010 28045000 28056549
39269000 39162010 39596000
All Match Values in sheet 1 are unique, while match values in sheet 2 may have duplicates because they correspond to multiple new values. So, if the match value in sheet 1 and sheet 2 are the same, then I want to replace the match value in sheet 1 with all of the new values that correspond to the match value. Sheet 1 after the replacements have been made should look like this:
Sheet 1:
Match Value
28051560
28056549
39596000
39269000
So as we can see, 28045000 was replaced by 2 values, 28051560 and 28056549 in 2 separate cells, while 39162010 was replaced by 39596000, while 39269000 which did not have a match value in sheet 2, remained the same.
I would typically do this manually, but there are about 30,000 rows of data, some with over to 10 values matching a single match value. I have the following code, however, this does not properly replace the match value with all of the new values. Is there a way to get Excel to search through the entire range of both sheets and make the proper changes automatically?
Sub multiFindNReplace()
Dim myList, myRange
Set myList = Sheets("sheet 1").Range("A1:A5000")
Set myRange = Sheets("sheet2").Range("A1:A5000")
For Each cel In myList.Columns(1).Cells
myRange.Replace what:=cel.Value, replacement:=cel.Offset(0, 1).Value
Next cel
End Sub
I would do it like this:
The macro just loop through the first sheet and compare it with the second sheet. If it matches, it replace the value in the first, add c+1 and go on with searching. Because the orginal value is replaced then, the orignal value is stored in d, if it find a second match it dones't replace it because of c+1, it goes to the else clause, insert a row and put the value in the new row. Like this it loops through the whole column on sheet1.
PS: I hope you can understand it, i didn't had that much time, will edit later for more readability.
Update:
So here we go again, i added the maxrow counter and overcomment it for a easy understanding.
Update 2:
Now with While-Loop because of for-loops doesn't regconize limit changes
Sub CompareLoop()
'Iterator Worksheet 1, is the counter for the ws1 column
Dim iWS1 As Integer
'Iterator Worksheet 2, is the counter for the ws1 column
Dim iWS2 As Integer
'Switch New Row, is the switch if the next value need a new row
Dim sNR As Integer
'Maximal Row Count, need to be extend when new rows are added
Dim MaxRows As Integer
'valueHolder, is the holder for the orginal value, the orginal value might be replaced on the sheet
Dim valueHolder As Long
'Worksheet1
Dim ws1 As Worksheet
'Worlsheet2
Dim ws2 As Worksheet
Set ws1 = ActiveWorkbook.Worksheets("table1")
Set ws2 = ActiveWorkbook.Worksheets("table2")
'Set iWS1 to the first row
iWS1 = 1
'Get MaxRows
MaxRows = ws1.Cells(Rows.Count, 1).End(xlUp).Row
'Loop through the Rows on WS1 setting switch to 0 and store the value from the ws1 row in the holder
While iWS1 <= MaxRows
sNR = 0
valueHolder = ws1.Cells(iWS1, 1).Value
'Loop through the Rows on WS2, searching for a value that match with the value from ws1
For iWS2 = 1 To ws2.Cells(Rows.Count, 1).End(xlUp).Row
'When it matches, then look if there was already a match with the value, if not replace it on the ws1 and increase the sNr to 1
If valueHolder = ws2.Cells(iWS2, 1).Value Then
If (sNR < 1) Then
ws1.Cells(iWS1, 1).Value = ws2.Cells(iWS2, 2).Value
sNR = sNR + 1
'When the sNR is already > 0, increase the Iterator for the ws1 that he will point on the new line
'increase the maxrows because we got one more soon, finally insert the new row and store the value from ws2 in it
Else
iWS1 = iWS1 + 1
MaxRows = MaxRows + 1
Range(ws1.Cells(iWS1, 1), ws1.Cells(iWS1, 1)).EntireRow.Insert
ws1.Cells(iWS1, 1).Value = ws2.Cells(iWS2, 2)
End If
End If
Next iWS2
iWS1 = iWS1 + 1
Wend
End Sub
Assuming Columns start at A are contiguous and are labelled, in Sheet 1, B2 and copied down to suit:
=IF(ISERROR(MATCH(A2,'Sheet 2'!A:A,0)),A2,"")
Copy range containing all values from Sheet 1 Column B and Paste Special, Values below last entry in Sheet 2 Column B.
Copy Sheet 2 Column B into A1 of Sheet 1 and filter to remove blanks in Column A. Delete Sheet 1 Column B.

Return column header based on row header and cell value

I have the following grid of data:
---------Header 1 Header 2 Header 3 Header 4
Row 1 x x x
Row 2 x x
Row 3 x
Row 4 x x x x
I then have a second sheet that looks like this:
Row 1 Row 2 Row 3 Row 4
I would like the second sheet to end up looking like this:
Row 1 Row 2 Row 3 Row 4
Header 1 Header 2 Header 3 Header 1
Header 3 Header 3 Header 2
Header 4 Header 3
. Header 4
Ignore that last period, I just used it to format it properly.
I've been playing with MATCH and INDEX for a couple hours and while I can get pieces of it, I can't seem to get it to all work together.
EDIT:
I use 'Header 1' and 'Row 1' as examples only. The actual data is text in Column A and Row 1, respectively. Also, since the source data will be modified, I'd prefer to have something that would automatically update the second sheet.
Here is one way to do it with a VBA function:
In the Developer Tab(*) Click on Visual Basic, then click on the "Insert" menu there and choose "Module" to insert a new module. Then paste in the Following code:
Option Explicit
Public Function GetHeaderMatchingRow(RowText As String, _
SearchRange As Range, _
iHdrNo As Integer) As String
Dim rng As Range
Set rng = SearchRange
Dim cel As Range
'Get the Row to scan
Dim i As Long, rowOff As Long
For i = 2 To rng.Rows.Count
Set cel = rng.Cells(i, 1)
If cel.Value = RowText Then
rowOff = i
Exit For
End If
Next i
'Now, scan horizontally for the iHdrNo'th non-blank cell
Dim cnt As Integer
For i = 2 To rng.Columns.Count
Set cel = rng.Cells(rowOff, i)
If Not CStr(cel.Value) = "" Then
cnt = cnt + 1
If cnt = iHdrNo Then
GetHeaderMatchingRow = rng.Cells(1, i).Value
Exit Function
End If
End If
Next i
GetHeaderMatchingRow = ""
End Function
Click on the "Debug" menu and select "Compile VBAProject".
Now go back to Excel and in your first sheet define a Named Range to cover all of your data in the grid. The Row names should be the first column in this range and the Header text should be the first row in it.
Now go to your second sheet and enter a formula like this in every output cell:
=GetHeaderMatchingRow(A$1, RowHeaderRange, 1)
Where the First parameter is the Row text that it will try to match in the first column of the range. I have "A$1" here because the in my test, my second sheet's column headers are also the Row-names in my first sheet, just like yours.
The second argument is the range to search (in this case, the Named Range we defined earlier), and the third argument is the count of the match that it is looking for (1st, 2nd, 3rd, etc.).
Note that the first and third parameters should change based on what column and row the output is for.
Does it have to use worksheet functions? It would be quite a bit simpler to create a macro to do it (I've made an example)
Edited the function to work with row headers in col a and column headers in row 1 and changed it to read from "Source" sheet and write the result to "Output" sheet
Public Sub Example()
Dim Output As Worksheet
Dim Sheet As Worksheet
Dim Row As Integer
Dim Column As Integer
Set Sheet = ThisWorkbook.Worksheets("Source")
Set Output = ThisWorkbook.Worksheets("Output")
Output.Cells.Clear ' Since were going to rebuild the whole thing, just nuke it.
For Row = Sheet.UsedRange.Rows(Sheet.UsedRange.Rows.Count).Row To 2 Step -1
Output.Cells(1, Row - 1).Value = Sheet.Cells(Row, 1).Value
For Column = Sheet.UsedRange.Columns(Sheet.UsedRange.Columns.Count).Column To 1 Step -1
If Not IsEmpty(Sheet.Cells(Row, Column)) Then
Sheet.Cells(1, Column).Copy
Output.Cells(2, Row - 1).Insert xlShiftDown
End If
Next Column
Next Row
End Sub
I had a look at doing it with worksheet functions and as others have said its going to be pretty tricky to do it without some vba mixed in there.
If you add this to a new module then you can access it as a workbook function. (not that this is the best way to do it, just fancied having a go)
'Return The Column Header of the Nth Non-Blank Cell on Specified Row
Public Function NonBlankByIndex(ByVal Row As Integer, ByVal Index As Integer) As Range
Dim Sheet As Worksheet
Dim Column As Integer
Dim Result As Range
Set Sheet = ThisWorkbook.Worksheets("Source") ' Change to your source sheet's name
Set Result = Nothing
Column = 2 ' Skip 1 as its the header
Do
If Column > Sheet.UsedRange.Columns(Sheet.UsedRange.Columns.Count).Column Then
Exit Do
End If
If Sheet.Cells(Row, Column) = "" Then
Column = Column + 1
Else
If Index = 1 Then
Set Result = Sheet.Cells(1, Column)
Exit Do
Else
Column = Column + 1
Index = Index - 1
End If
End If
Loop
Set NonBlankByIndex = Result
End Function
If you are happy with blanks in the listing try this in sheet2!A2:
=IF(INDEX(Sheet1!$B$2:$E$5,MATCH(A$1,Sheet1!$A$2:$A$5,0),ROW()-1)="x",INDEX(Sheet1!$B$1:$E$1,1,ROW()-1),"")
Just copy the formula over range A2:D5

Resources