I have VBA code that works to delete entire row when there is an absolute zero value in one a cell column but, I am not able to figure out how to update code to apply to all worksheets (there are 20 Sheets in my workbook):
Can someone help with syntax how to update this code to apply to all worksheets in the workbook.
Sub IfandthenDelete_Button3_Click()
Dim lRow As Long
Dim i As Long
lRow = 3000
Application.ScreenUpdating = False
For i = lRow To 1 Step -1
If Cells(i, 1) = 0 Then
Rows(i).Delete
End If
Next
Application.ScreenUpdating = False
End Sub
You need one more for loop for that.
Sub WorksheetLoop()
Dim wsCount As Integer
Dim j As Integer
Dim lRow As Long
Dim i As Long
lRow = 3000
wsCount = ActiveWorkbook.Worksheets.Count
For j = 1 To wsCount
For i = lRow To 1 Step -1
If ActiveWorkbook.Worksheets(j).Cells(i, 1) = 0 Then
ActiveWorkbook.Worksheets(j).Rows(i).Delete
End If
Next
Next j
End Sub
Related
I have a range of numbers in Sheet1 (AG6:AG25) that contain the RAND() function, and I'm looking to iterate the outcomes for each via pasting transposed values into Sheet2 on a new row for each iteration.
Solved as follows:
Sub MonteCarlo()
Dim transposedVariant As Variant
Dim sourceRowRange As Range
Dim sourceRowRangeVariant As Variant
Dim rangeFilledWithTransposedData As Range
Dim i As Long
Application.ScreenUpdating = False
For i = 1 To 5000
Set sourceRowRange = Sheets("Sheet1").Range("AG6:AG25")
sourceRowRangeVariant = sourceRowRange.Value
transposedVariant = Application.Transpose(sourceRowRangeVariant)
Set rangeFilledWithTransposedData = Sheets("Sheet2").Range("A" & i & ":T" & i)
rangeFilledWithTransposedData.Value = transposedVariant
Next i
Application.ScreenUpdating = True
End Sub
Please find the code. I hope it will help you.
Sub simulation()
Dim i As Long
Dim j As Long
For i = 1 To 1000
For j = 1 To 20
'Calculate
Sheet1.Cells(j, 1) = Application.WorksheetFunction.RandBetween(100, 150) * 1
Next j
Next i
End Sub
I have this table:
Quantity Name
1 A
3 C1
3 C2
4 D
I'm trying to make this table change to:
Quantity Name
1 A
1 A
3 C1
3 C1
3 C1
3 C2
3 C2
3 C2
4 D
4 D
4 D
4 D
But the result is not as expect: Result
Pls help my solve this problem.
Thanks!
Here is my code:
Sub newrow()
Dim xRg As Range
Dim xAddress As String
Dim I, xNum, xLastRow, xFstRow, xCol, xCount As Long
On Error Resume Next
xAddress = ActiveWindow.RangeSelection.Address
Set xRg = Application.InputBox("Select a range to use(single column):", "KuTools For Excel", xAddress, , , , , 8)
If xRg Is Nothing Then Exit Sub
Application.ScreenUpdating = False
xLastRow = xRg(1).End(xlDown).Row
xFstRow = xRg.Row
xCol = xRg.Column
xCount = xRg.Count
Set xRg = xRg(1)
For I = xLastRow To xFstRow Step -1
xNum = Cells(I, xCol)
If IsNumeric(xNum) And xNum > 0 Then
Rows(I + 1).Resize(Cells(I, xCol) - Cells(I - 1, xCol)).Insert
xCount = xCount + xNum
End If
Next
xRg.Resize(xCount, 1).Select
Application.ScreenUpdating = True
End Sub
First of all …
If you Dim xFstRow, xCol, xCount As Long then only xCount is of type Long all the others are of type Variant. You need to specify a type for every variable!
Dim xFstRow As Long, xCol As Long, xCount As Long
Don't ever use On Error Resume Next without proper error handling. This only hides error messages but the errors still occur you just cannot see them. Therefore you cannot debug/fix your code. Remove it completely or implement a complete error handling instead.
You need to copy the row before you insert, otherwise you just insert empty rows.
I suggest the following code:
Option Explicit
Public Sub AddRowsFromQantities()
Dim SelAddress As String
SelAddress = ActiveWindow.RangeSelection.Address
Dim SelRange As Range
Set SelRange = Application.InputBox("Select a range to use(single column):", "KuTools For Excel", SelAddress, , , , , 8)
Dim fRow As Long
fRow = SelRange.Row 'first row of selected rang
Dim lRow As Long
lRow = fRow + SelRange.Rows.Count - 1 'last row of selected range
'find last used row within the selected range
If Cells(Rows.Count, 1).End(xlUp).Row < lRow Then
lRow = Cells(Rows.Count, 1).End(xlUp).Row
End If
Application.ScreenUpdating = False
Dim iRow As Long
For iRow = lRow To fRow Step -1
If IsNumeric(Cells(iRow, 1)) Then
Dim Quantity As Long
Quantity = Cells(iRow, 1).Value
If Quantity > 1 Then
Rows(iRow).Copy
Rows(iRow).Resize(RowSize:=Quantity - 1).Insert
End If
End If
Next iRow
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
I have the following VBA code for excel
Dim k As Integer, z As Integer
Dim sourceSht As Worksheet
Dim destSht As Worksheet
z = 0
Set sourceSht = Sheets("sheet1")
Set destSht = Sheets("sheet2")
DoEvents
For k = 1 To 5000
If k < 3 Or (k - 1) Mod 3 <> 0 Then
z = z + 1
sourceSht.Columns(k).Copy destSht.Columns(z)
End If
Next
This code was working perfectly for rows (changed this part"sourceSht.Columns(k).Copy destSht.Columns(z)").
but I can not make it work for columns. I want excel to copy the first 2 columns then skip the third one, then copy 2 again, skip one and etc... can somebody help me and explain what am I doing wrong?
I'm going to ignore the use of mod and do a Step 3 with the loop:
Dim i as Long, j as Long
For i = 1 to 5000 Step 3
With sourceSht
If j = 0 Then
j = 1
Else
j = j + 2 'Copying 2 columns over, so adding 2 each time
End If
.Range(.Columns(i),.Columns(i+1)).Copy destSht.Range( destSht.Columns(j), destSht.Column(j+1))
End With
Next i
Something like that should do it for you
Alternate:
Sub tgr()
Dim wsSource As Worksheet
Dim wsDest As Worksheet
Dim rCopy As Range
Dim rLast As Range
Dim LastCol As Long
Dim i As Long
Set wsSource = ActiveWorkbook.Sheets("Sheet1")
Set wsDest = ActiveWorkbook.Sheets("Sheet2")
On Error Resume Next
Set rLast = wsSource.Cells.Find("*", wsSource.Range("A1"), xlFormulas, , xlByColumns, xlPrevious)
On Error GoTo 0
If rLast Is Nothing Then Exit Sub 'No data
LastCol = rLast.Column
Set rCopy = wsSource.Range("A:B")
For i = 4 To LastCol Step 3
Set rCopy = Union(rCopy, wsSource.Columns(i).Resize(, 2))
Next i
rCopy.Copy wsDest.Range("A1")
End Sub
Try this (use count for the number of time you need to copy columns, t for the first columns you need to copy):
Sub copy_columns()
t = 1
Count = 1
Do Until Count = 10
Range(Columns(t), Columns(t + 1)).Copy
Cells(1, t + 3).Select
Selection.PasteSpecial Paste:=xlPasteValues
t = t + 3
Count = Count + 1
Loop
End Sub
I wanted to add a row in excel vba when ever the value in column A is 1, here is the code I wrote, but this returns a "subscript out of range error". What am I doing wrong?
Sub InsertRow()
Dim Col As Variant
Dim BlankRows As Long
Dim LastRow As Long
Dim R As Long
Dim StartRow As Long
Application.ScreenUpdating = False
Col = "A"
StartRow = 1
LastRow = 20
Worksheets("Sheet1").Activate
For R = StartRow To LastRow
If Cells(R, Col) = 1 Then
Cells(R, Col).EntireRow.Insert Shift:=xlDown
End If
Next R
Application.ScreenUpdating = True
End Sub
Code below tested and works.
With Worksheets("Sheet1")
Dim cntr as Long
For cntr = 20 to 5 Step - 1
If .Cells(cntr, 1) = 1 Then .cells(cntr,1).EntireRow.Insert Shift:=xlDown
Next
End With
Sub InsertRow()
Dim Col As Variant
Dim BlankRows As Long
Dim LastRow As Long
Dim R As Long
Dim StartRow As Long
Application.ScreenUpdating = False
Col = "A"
StartRow = 1
LastRow = 20
Worksheets("Sheet1").Activate
R = StartRow
Do While R <= LastRow
If Cells(R, Col) = 1 Then
Cells(R, Col).EntireRow.Insert Shift:=xlDown
R = R + 1
LastRow = LastRow + 1
End If
R = R + 1
Loop
Application.ScreenUpdating = True
End Sub
Note the setting of the value of R in the loop, as you are shifting the rows down, you are continually checking the same value and therefore adding a row each time so we need to increment R by 1 to skip past the 1 we just checked.
We also need to change the endpoint as we are pushing values past Row 20 by inserting so we also increment the LastRow variable. We cannot do this in a for loop in VBA, the for loop will terminate at 20 so I have changed to a while loop
As per the comment below, working backwards from 20 is far more elequent but since I didn't think of that I haven't put it in here :)
I have a loop towards the bottom of my code that successfully loops through my data and clears out all rows where Column H = 0.
However, there are several cells in column B displaying #REF!. I would also like this loop to delete those rows in the same manner as it does the 0s in column H.
I think my issue is not knowing how to reference those types of errors. Treating #REF! like a string doesn't appear to be working.
Thank you!
Sub test()
Dim currentSht As Worksheet
Dim lastRow As Long
Dim lastCol As Long
Dim startCell As Range
Dim r As Integer
Set startCell = Sheets("Sheet1").Range("A1")
Set currentSht = ActiveWorkbook.Sheets("Sheet1")
lastRow = startCell.SpecialCells(xlCellTypeLastCell).Row '<~~ Not sure why, but do not use "Set" when defining lastRow
lastCol = startCell.SpecialCells(xlCellTypeLastCell).Column
For r = 1 To lastRow Step -1
If currentSht.Cells(r, "H").Value = 0 Or currentSht.Cells(r, "B").Text = "#REF!" Then
Rows(r).Select
Selection.EntireRow.Delete
End If
Next r
currentSht.Range(startCell, currentSht.Cells(lastRow, lastCol)).Select
End Sub
I think I see your problem:
For r = 1 To lastRow Step -1
Change that line to
For r = lastrow to 1 Step -1
How about this code:
Sub Delete0()
Dim F As Integer
Dim Y As Integer
Dim RngCount As Range
Set RngCount = ActiveSheet.Range("H:H")
Y = Application.WorksheetFunction.CountA(RngCount)
For F = Y To 1 Step -1
If IsError(ActiveSheet.Range("H" & F)) Then
ActiveSheet.Rows(F).EntireRow.Delete
ElseIf ActiveSheet.Range("H" & F).Value = 0 Then
ActiveSheet.Rows(F).EntireRow.Delete
End If
Next F
End Sub