I need some help regarding my Macro.
My issue is the VBA hide the empty rows as well.
Can someone help me, I just want to hide the 0 row not the empty?
Many thanks.
Sub HideRows()
Dim i As Long
Dim j As Long
Dim hide As Boolean
'loop through rows
For i = 32 To 262
hide = True
'loop in the row: B through AF column
For j = 4 To 41
'if we found value greater then zero, then we don't want to hide this row
If Cells(i, j).Value > 0 Then
hide = False
Exit For
End If
Next j
Rows(i).Hidden = hide
Next i
End Sub
Hide Rows Containing Only Zeros
' Task: Hide rows where all cells contain the number 0.
Sub HideRows()
Dim cValue, i As Long, j As Long
For i = 32 To 262
For j = 2 To 32 ' columns 'B' through 'AF'
cValue = Cells(i, j).Value
If VarType(cValue) = vbDouble Then ' is a number
If cValue <> 0 Then Exit For
Else ' is not a number
Exit For
End If
Next j
Rows(i).Hidden = j > 32
Next i
End Sub
Related
Is it possible to get the row positions in a large table in excel without performing a loop?
What I am trying to do is to click on a particular ID, and then the last 3 records from the same ID will be shown in UI.
I am beginner in programming and have no idea how to do this aside from looping method (which is very resource and memory-intensive considering we are looping a large and growing table of 100k rows in every single click from user).
For example: If user is clicking "A123" then we know that their row positions are : 5, 8 , 10
Same as CDP1802 posted but faster finding of last 3 rows.
Sub FilteredAdvanced()
Const nValues As Long = 3 'amount of rows you want to find from the end
Dim ar() As Long
ReDim ar(nValues - 1) As Long
' apply filter
With Sheet1
.AutoFilterMode = False
.UsedRange.AutoFilter 1, "A123"
Dim rng As Range
Set rng = .UsedRange.Columns(1).SpecialCells(xlCellTypeVisible)
.UsedRange.AutoFilter 'remove filter
End With
Dim n As Long
n = nValues - 1
Dim iArea As Long
For iArea = rng.Areas.Count To 1 Step -1
Dim iRow As Long
For iRow = rng.Areas(iArea).Rows.Count To 1 Step -1
ar(n) = rng.Areas(iArea).Rows(iRow).Row
n = n - 1
If n < 0 Then Exit For
Next iRow
If n < 0 Then Exit For
Next iArea
Dim j As Long
For j = 0 To nValues - 1
Debug.Print ar(j)
Next
End Sub
Looping filtered a list
Option Explicit
Sub Filtered()
Dim rng as Range, ID As Range, a As Range
Dim ar(2) As Long, i As Integer, j As Integer
' apply filter
With Sheet1
.AutoFilterMode = False
.UsedRange.AutoFilter 1, "A123"
Set rng = .UsedRange.Columns(1).SpecialCells(xlCellTypeVisible)
End With
' count
For Each a In rng.Areas
For Each ID In a.Cells
If ID.Row > 1 Then
i = (i + 1) Mod 3
ar(i) = ID.Row
End If
Next
Next
For j = 1 To 3
Debug.Print ar((j + i) Mod 3)
Next
End Sub
I have simple a stock list which is working with a textbox and a listbox.
When i write a word to textbox ( like flange ), i can see every stock name which is including same word at the listbox. ( i can see every stock name which is including flange word at listbox.)
Below codes work fine in my computer.
But when i send this excel sheet to another computer, Listbox is getting smaller and smaller when i type any keyboard key.
How could i avoid this error?
How could i work with this excel sheet in everyone's pc without having this problem?
Is anyone have an idea?
Private Sub TextBox1_Change()
'To avoid any screen update until the process is finished
Application.ScreenUpdating = False
'This method must make sure to turn this property back to True before exiting by
' always going through the exit_sub label
On Error GoTo err_sub
'This will be the string to filter by
Dim filterSt As String: filterSt = Me.TextBox1.Text & ""
'This is the number of the column to filter by
Const filterCol As Long = 4 'This number can be changed as needed
'This is the sheet to load the listbox from
Dim dataSh As Worksheet: Set dataSh = Worksheets("T?mListe") 'The sheet name can be changed as needed
'This is the number of columns that will be loaded from the sheet (starting with column A)
Const colCount As Long = 6 'This constant allows you to easily include more/less columns in future
'Determining how far down the sheet we must go
Dim usedRng As Range: Set usedRng = dataSh.UsedRange
Dim lastRow As Long: lastRow = usedRng.Row - 1 + usedRng.Rows.Count
Dim c As Long
'Getting the total width of all the columns on the sheet
Dim colsTotWidth As Double: colsTotWidth = 0
For c = 1 To colCount
colsTotWidth = colsTotWidth + dataSh.Columns(c).ColumnWidth
Next
'Determining the desired total width for all the columns in the listbox
Dim widthToUse As Double
'Not sure why, but subtracting 4 ensured that the horizontal scrollbar would not appear
widthToUse = Me.ListBox1.Width - 4
If widthToUse < 0 Then widthToUse = 0
'Making the widths of the listbox columns proportional to the corresponding column widths on the sheet;
' thus, the listbox columns will automatically adjust if the column widths on the sheet are changed
Dim colWidthSt As String: colWidthSt = "" 'This will be the string used to set the listbox's column widths
Dim totW As Double: totW = 1
For c = 1 To colCount
Dim w As Double
If c = colCount Then 'Use the remaining width for the last column
w = widthToUse - totW
Else 'Calculate a proportional width
w = dataSh.Columns(c).ColumnWidth / colsTotWidth * widthToUse
End If
'Rounding to 0 decimals and using an integer to avoid localisation issues
' when converting the width to a string
Dim wInt As Long: wInt = Round(w, 0)
If wInt < 1 And w > 0 Then wInt = 1
totW = totW + wInt
If c > 1 Then colWidthSt = colWidthSt & ","
colWidthSt = colWidthSt & wInt
Next
'Reset the listbox
Me.ListBox1.Clear
Me.ListBox1.ColumnCount = colCount
Me.ListBox1.ColumnWidths = colWidthSt
Me.ListBox1.ColumnHeads = False
'Reading the entire data sheet into memory
Dim dataArr As Variant: dataArr = dataSh.UsedRange
If Not IsArray(dataArr) Then dataArr = dataSh.Range("A1:A2")
'If filterCol is beyond the last column in the data sheet, leave the list blank and simply exit
If filterCol > UBound(dataArr, 2) Then GoTo exit_sub 'Do not use Exit Sub here, since we must turn ScreenUpdating back on
'This array will store the rows that meet the filter condition
ReDim filteredArr(1 To UBound(dataArr, 1), 1 To UBound(dataArr, 2)) 'Make room for the maximum possible size
Dim filteredCount As Long: filteredCount = 0
'Copy the matching rows from [dataArr] to [filteredArr]
'IMPORTANT ASSUMPTION: The first row on the sheet is a header row
Dim r As Long
For r = 1 To lastRow
'The first row will always be added to give the listbox a header
If r > 1 And InStr(1, dataArr(r, filterCol) & "", filterSt, vbTextCompare) = 0 Then
GoTo continue_for_r
End If
'NB: The Like operator is not used above in case [filterSt] has wildcard characters in it
' Also, the filtering above is case-insensitive
' (if needed, it can be changed to case-sensitive by changing the last parameter to vbBinaryCompare)
filteredCount = filteredCount + 1
For c = 1 To colCount
filteredArr(filteredCount, c) = dataArr(r, c)
Next
continue_for_r:
Next
'Copy [filteredArr] to a new array with the right dimensions
If filteredCount > 0 Then
'Unfortunately, Redim Preserve cannot be used here because it can only resize the last dimension;
' therefore, we must manually copy the filtered data to a new array
ReDim filteredArr2(1 To filteredCount, 1 To colCount)
For r = 1 To filteredCount
For c = 1 To colCount
filteredArr2(r, c) = filteredArr(r, c)
Next
Next
Me.ListBox1.List = filteredArr2
End If
ListBox1.Height = 772
ListBox1.Width = 1300
ListBox1.Top = 75
exit_sub:
Application.ScreenUpdating = True
Exit Sub
err_sub:
MsgBox "Error " & Err.Number & vbCrLf & vbCrLf & Err.Description
Resume exit_sub 'To make sure that screen updating is turned back on
End Sub
Thanks in advance.
I am trying to write a VBA script where for every 5 counts of the number, the numbering starts back at 1. I'm taking the user input to loop through how many times the user wants to have the number set. Problem is, the numbers are not restarting from 1. Please help!!
Example: user enters 2 times, expected result is-
1
2
3
4
5
1
2
3
4
5
Code:
Dim myValue, myRows As Variant
Dim i, j, x, y, m, n, k As Integer
Sub Button1_Click()
'myValue = InputBox("Enter a starting number")
myRows = InputBox("Enter how times to repeat")
'Call repeat(myRows)
Call repeat2(myRows)
End Sub
Sub repeat2(rep1)
m = 0
n = 0
k = 1
For k = 1 To myRows
'k = k + 1
m = m + 5
n = n + 5
Call autogen2(k)
Next k
End Sub
Sub autogen2(z)
For k = 1 To m + 5
Range("F" & k).Select
ActiveCell.FormulaR1C1 = k
ActiveCell.Offset(1, 0).Select
Next k
End Sub
Your method seems overly complicated and loops through every cell instead of looping through groups of the target cells.
To simplify the math in calculating the target, I'd suggest Option Base 1 as a compiler directive in the code sheet's declarations area. This changes the default for an array from zero based to one based; i.e. from 0 to 4 to 1 to 5.
By using LBound and UBound, you can change the array without cahnging any of the other code that shapes the target.
Option Explicit
Option Base 1
Sub Button1_Click()
Dim myRows As Long, seq As Variant
'myValue = InputBox("Enter a starting number")
myRows = Application.InputBox(prompt:="Enter how times to repeat", Type:=xlNumbers)
If IsNumeric(myRows) Then
seq = Array(1, 2, 3, 4, 5)
autogen seq, myRows
End If
End Sub
Sub autogen(vals As Variant, n As Long)
Dim k As Long
For k = LBound(vals) To (n * UBound(vals)) Step UBound(vals)
Cells(1, "F").Offset(k - 1, 0).Resize(UBound(vals), 1) = _
Application.Transpose(vals)
Next k
End Sub
Number Generator (Fast)
Adjust the constants (Const) to fit your needs.
Option Explicit
Sub Button1_Click()
Dim myRows As Variant
myRows = InputBox("Enter how times to repeat")
If IsNumeric(myRows) Then
Repeat CLng(myRows)
End If
End Sub
Sub Repeat(Rows As Long)
Const cRange As String = "F1" ' First Cell Range Address
Const cStart As Long = 1 ' Starting Value
Const cEnd As Long = 5 ' Ending Value
Dim vntT As Variant ' Target Array
Dim i As Long ' Rows Counter
Dim k As Long ' Value Counter
Dim m As Long ' Target Array Row Counter
' Resize Target Array: Number of Values times Rows.
ReDim vntT(1 To (cEnd - cStart + 1) * Rows, 1 To 1)
' Loop through Rows.
For i = 1 To Rows
' Loop through Values.
For k = cStart To cEnd
' Count Target Array Row.
m = m + 1
' Write current Value to element in current Target Array Row.
vntT(m, 1) = k
Next
Next
With Range(cRange)
' Clear contents of Target Column Range from First Cell Range to
' bottom cell.
.Resize(.Worksheet.Rows.Count - .Row + 1).ClearContents
' Calculate Target Range: resize First Cell Range by Target Array Rows.
' Copy Target Array to Target Range.
.Resize(m) = vntT
End With
End Sub
One more:
Dim myRows As Long, tot As Long
myRows = Application.InputBox("Enter how times to repeat")
tot = myRows * 5
With ActiveSheet.Range("K1").Resize(tot, 1)
.FormulaArray = "=1+MOD(ROW(1:" & tot & ")-1,5)"
.Value = .Value
End With
Gettin a "Type Mismatch" error.
Trying to take one matrix of numbers on one worksheet "Sheet1", divide by another matrix of numbers on a second worksheet "Sheet2", then show each cell result on a matrix on the third worksheet "Sheet1"
Sub MacroTest()
Worksheets("Sheet3").Range("C5") = Worksheets("Sheet1").Range("C5:DR124") / Worksheets("Sheet2").Range("C5:DR124")
End Sub
With this code you can do what you need on specific range (that you can choose) on different sheet and also on the same sheet.
Sub RangeDiv()
Dim RngFrom As Range
Dim RngDiv As Range
Dim RngTo As Range
Dim R As Integer
Dim C As Integer
Set RngFrom = Sheets(1).Range("A1:E3")
Set RngDiv = Sheets(1).Range("B6:F8")
Set RngTo = Sheets(1).Range("C10:G12")
'Check if all Rngs have the same number of rows and columns
If RngFrom.Rows.Count <> RngDiv.Rows.Count Or RngFrom.Rows.Count <> RngTo.Rows.Count Then
MsgBox ("Rngs rows number aren't equal")
Exit Sub
End If
If RngFrom.Columns.Count <> RngDiv.Columns.Count Or RngFrom.Columns.Count <> RngTo.Columns.Count Then
MsgBox ("Rngs columns number aren't equal")
Exit Sub
End If
For C = 1 To RngFrom.Columns.Count
For R = 1 To RngFrom.Rows.Count
'check cell value to avoid errors coming from dividing by 0
If Val(RngDiv.Cells(R, C)) <> 0 Then
RngTo.Cells(R, C) = RngFrom.Cells(R, C) / RngDiv.Cells(R, C)
Else
'Insert something when division is impossible
RngTo.Cells(R, C) = 0 'Or what you want to insert
End If
Next R
Next C
End Sub
I create sheet1 like this
Please click to see Image
then sheet2
Please click to see Image2
then create blank sheet 3
and use this code
Sub divideRange()
Dim lastRow, lastColumn As Long
lastColumn = Sheets("Sheet1").Cells(1, Columns.Count).End(xlToLeft).Column
lastRow = Sheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row
For i = 1 To lastRow
For j = 1 To lastColumn
Sheets("Sheet3").Cells(i, j).Value = Sheets("Sheet1").Cells(i, j).Value / Sheets("Sheet2").Cells(i, j).Value
Next j
Next i
End Sub
Is this what you want?
Sorry for my late reply.
You can solve your problem with a for-loop:
For i = 3 To 9
If IsNumeric(Worksheets("Tabelle2").Cells(5, i).Value) And IsNumeric(Worksheets("Tabelle3").Cells(5, i).Value) And Worksheets("Tabelle3").Cells(5, i).Value <> 0 Then
Worksheets("Tabelle1").Cells(5, i).Value = Worksheets("Tabelle2").Cells(5, i).Value / Worksheets("Tabelle3").Cells(5, i).Value
End If
Next
variable i is your column as a number. A = 1, B = 2, Z = 26, AA = 27 and so on..
number 5 is your row
For example
Cells(5,1) is the same like Range("A5") or Cells(3,9) = Range("I3")
In my code above, it starts with column C (3) and stops with column I (9). Replace the Number 9 with the number of the Column FX (your last column) and edit the table Names then it should work.
I have a spreadsheet with thousands of rows and in column B there are numerous duplicates and then in column G there is that row's respective value. I need to remove the duplicates from column B, but leave in the row that has the highest value (i.e max column G). Is there a way to automate this via VBA as it'll need to be done on numerous occasions?
Thanks
You can try this:
Sub test()
Dim i As Long, j As Long
Dim wb As Workbook, ws As Worksheet
Set wb = ThisWorkbook
Set ws = wb.Sheets("Sheet1") ' Change the name of your sheet
With ws
i = 1 ' Start at Row 1
Do While Not IsEmpty(.Cells(i, 2))
j = 1 ' Start at Row 1
Do While Not IsEmpty(.Cells(j, 2))
If i <> j Then
If .Cells(i, 2).Value = Cells(j, 2).Value Then
If .Cells(i, 7).Value > Cells(j, 7) Then
Rows(j).EntireRow.Delete
j = j - 1
Else
Rows(i).EntireRow.Delete
If i > 1 Then i = i - 1
j = 1
End If
End If
End If
j = j + 1
Loop
i = i + 1
Loop
End With
End Sub