I have created a Looping VBA to update values according to data in Columns A,B,C,D. But I need to stop this Looping once 'D' Column is empty or has no values.
Sub Macro1()
'
' Set Do loop to stop when an empty cell is reached.
Do Until IsEmpty(ActiveCell)
Range("C2").Select
Range("C2").End(xlDown).Offset(1, -2).Select
Selection.ClearContents
Range("C2").End(xlDown).Offset(0, -2).Select
Range(Selection, Selection.End(xlUp)).Select
Selection.FillDown
Range("C2").End(xlDown).Offset(1, 0).Select
ActiveCell.FormulaR1C1 = "Logged out"
ActiveCell.Offset(1, 0).Select
Loop
End Sub
There are many ways to accomplish this task. Here is one method.
Sub Test1()
'UpdatebyExtendoffice20161222
Dim x As Integer
Application.ScreenUpdating = False
' Set numrows = number of rows of data.
NumRows = Range("D1", Range("D1").End(xlDown)).Rows.Count
' Select cell D1.
Range("D1").Select
' Establish "For" loop to loop "numrows" number of times.
For x = 1 To NumRows
' Insert your code here.
' Selects cell down 1 row from active cell.
ActiveCell.Offset(1, 0).Select
Next
Application.ScreenUpdating = True
End Sub
If isEmpty(Range(x)) then exit do end if
Related
I have an Excel Sheet wherein column "A" contains Serial numbers. One serial number may repeat to several rows. The cells in column "A" are merged [if more than one rows are appearing for One serial number]. I have made following macro to UN-merge these cells and repeat the serial number in subsequent blank rows until next serial number appears. The problem I am facing is that this macro is running very slow e.g. for a sheet containing 30,000 rows it may take a very long time. Is there a neat and less slower way to do it?
Here is the code I am using. Please guide.
Sub Unmerge_Cell()
Dim NumRows As Integer
Range("B2").Select
NumRows = Range("B2", Range("B2").End(xlDown)).Rows.Count
Columns("A:A").Select
Selection.UnMerge
Range("A2").Select
Range("A2").Activate
For i = 1 To NumRows - 1
If IsEmpty(ActiveCell.Offset(1, 0).Value) = True Then
ActiveCell.Select
Selection.Copy
ActiveCell.Offset(1, 0).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Else
ActiveCell.Offset(1, 0).Select
ActiveCell.Offset(0, 0).Activate
End If
Next
Range("A1").Select
End Sub
Regards
This should be the fastest solution, no loop, simple.
Sub unMerge()
Dim lastRow As Long
lastRow = Range("B2").End(xlDown).Row
Range("A:A").unMerge
Range("A2:A" & lastRow).SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=r[-1]c"
With Range("A2:A" & lastRow)
.Value = .Value 'convert formula to constant
End With
End Sub
I tried to simplyfy your code. I haven't tested it in Excel ;-/
Sub Unmerge_Cell()
Dim NumRows As Integer
Dim i as Long
NumRows = Range("B2", Range("B2").End(xlDown)).Rows.Count
For i = 1 To NumRows - 1
If IsEmpty(Range("A2").Offset(i,0).Value) Then
Range("A2").Offset(i,0).Value = Range("A2").Offset(i-1,0).Value
End If
Next
End Sub
You can also turn off and turn on the screen updating when you macro is running
At the beginning on your code insert
application.screenupdating = false
And turn it on at the end
application.screenupdating = true
I have some code that filters a large data set, then selects visible cells, and copy & pastes the range elsewhere.
Sub Filterstuff()
' Select & Filter data
Sheets("Main").Select
Lastrow = ActiveSheet.Range("A2").End(xlDown).Row
Range("A1").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.AutoFilter
' Filter for things
ActiveSheet.Range("A1:AU" & Lastrow).AutoFilter Field:=39, Criteria1:="words"
ActiveSheet.Range("A1:AU" & Lastrow).AutoFilter Field:=43, Criteria1:= _
"<>*wordswords*"
' Find the first unfiltered cell
Range("A1").Select
ActiveCell.Offset(1, 0).Select
Do Until ActiveCell.EntireRow.Hidden = False
ActiveCell.Offset(1, 0).Select
Loop
' If there are no unfiltered cells, exit
If ActiveCell.Row = Lastrow + 1 Then
Exit Sub
' Else paste results normally
Else
Range(Selection, Selection.Offset(0, 47)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.SpecialCells(xlCellTypeVisible).Select
Selection.Copy
' Paste to bottom
Sheets("PasteSheet").Select
countrows = Cells(Cells.Rows.Count, "A").End(xlUp).Row
Range("A" & countrows + 1).Select
ActiveSheet.Paste
End If
' Return to Main and unfilter
Sheets("Main").Select
Cells.Select
ActiveSheet.ShowAllData
Selection.AutoFilter
End Sub
My issue is located in the code block meant to exit the sub if everything gets filtered out and there are no resulting rows with data after filtering. The relevant code begins at the commented section "Find the first unfiltered cell".
This code finds the first unhidden row, and checks if it is after the last row of data in the data set. My issue is that it is exceedingly slow. My data set can be 100,000+ rows and looping through it using ActiveCell.Offset(1, 0).Select takes forever.
How can I re-tool this code to exit the sub if everything gets filtered out?
Avoid using Select (this will improve the runtime performance):
http://stackoverflow.com/questions/10714251
Then, get a handle on the full range of "data". Finally, after applying autofilter, check the range's SpecialCells(xlCellTypeVisible).Count.
As long as that .Count is greater than the number of columns in your range, then you have at least one visible row of data (assuming your data has headers -- if there are no headers, you can just compare whether > 0).
Untested:
Sub Filterstuff()
' Select & Filter data
Dim ws as Worksheet
Dim rng as Range
Set ws = Worksheets("Main")
Set rng = ws.Range("A2:AU" & ws.Range("A2").End(xlDown).Row))
rng.AutoFilter
' Filter for things
rng.AutoFilter Field:=39, Criteria1:="words"
rng.AutoFilter Field:=43, Criteria1:="<>*wordswords*"
' Find the first unfiltered cell
If rng.SpecialCells(xlCellTypeVisible).Count > rng.Columns.Count Then
'Autofilter has returned at least one row of data
Else
MsgBox "No data results from Autofilter"
Exit Sub
End If
<more code...>
Here is my code
Sub A_Copy_To_Prior_Row_column()
'
' A_Copy_To_Prior_Row_column Macro
'
'
Application.CutCopyMode = False
Selection.Copy
Range("R183").Select
ActiveSheet.Paste
End Sub
Where R183 is I need to not a specific cell, but a cell based on minus 1 row, and +17 columns of the selected/highlighted cell I wish to copy
Sub A_Copy_To_Prior_Row_column()
'
' A_Copy_To_Prior_Row_column Macro
'
'
Application.CutCopyMode = False
With Selection
.Copy
ActiveSheet.Paste Destination:=.Offset(-1, 17)
End With
End Sub
activecell.Offset(-1, 17).Value = activecell.Value
I need the macro to go down a column in Excel and run the TEST procedure until the cells are empty. The TEST procedure always ends with the cell you started with selected. Here is how it looks manually but I would like to code it to run on a loop until the cell in column "B" is empty. Thanks in advance for any help. Here is what I am doing now (without a loop):
Sub NotLooped()
Windows("Pattern Scanv4.xlsm").Activate
Sheets("DATA").Select
Range("B2").Select
Application.Run ("TEST")
If ActiveCell.Offset(1, 0).Value = 0 Then
ElseIf ActiveCell.Offset(1, 0).Value > 0 Then
ActiveCell.Offset(1, 0).Range("A1").Select
Application.Run ("TEST")
End If
If ActiveCell.Offset(1, 0).Value = 0 Then
ElseIf ActiveCell.Offset(1, 0).Value > 0 Then
ActiveCell.Offset(1, 0).Range("A1").Select
Application.Run ("TEST")
End If
'etc.................
If ActiveCell.Offset(1, 0).Value = 0 Then
ElseIf ActiveCell.Offset(1, 0).Value > 0 Then
ActiveCell.Offset(1, 0).Range("A1").Select
Application.Run ("TEST")
End If
If ActiveCell.Offset(1, 0).Value = 0 Then
ElseIf ActiveCell.Offset(1, 0).Value > 0 Then
ActiveCell.Offset(1, 0).Range("A1").Select
Application.Run ("TEST")
End If
End Sub
Try this:
Sub Looped()
Dim sht As Worksheet, rng as Range
Set sht = Workbooks("Pattern Scanv4.xlsm").Sheets("DATA")
sht.Parent.Activate
sht.Select
Set rng = sht.Range("B2")
Do While Len(rng.value) > 0
rng.Select
TEST
Set rng = rng.offset(1,0)
Loop
End Sub
However it would be much better if your code didn't rely on a particular sheet being active or a given range being selected.
If you modify your TEST Sub to add a Range parameter then you can pass rng directly to it.
i.e. instead of:
Sub TEST()
...do something with selection/activecell
you can do this:
Sub TEST(rng As Range)
...do something with rng
and call it like this:
TEST rng
See How to avoid using Select in Excel VBA macros
Need a code snippet; if some kind guru could help, please. I need to express the following cursor movement sequence in XL VBA.
After entering a formula in cell A1 (Col-A is otherwise empty), I need to copy the formula to all cells in the range A1:AN, where N is the last row of the table.
I recorded a macro to do the following (code below):
1) enter the formula (in Cell A1)
2) copy the formula
3) go Right to B1
4) go to the last populated cell in Col-B [using Ctrl+Down] (easiest way to find the last row)
5) go Left to Col-A
6) select all cells from current to A1
7) paste the formula to the selection
The part I need help with is a way to capture the cell address in step 5 as a variable so that I can use this macro on a series of files having a variable number of rows.
Here is the recorded macro. In this example, the last row in the table is 7952.
Sub test()
ActiveCell.FormulaR1C1 = "=LEFT(RC[1],3)"
ActiveCell.Select
Selection.Copy
ActiveCell.Offset(0, 1).Range("A1").Select
Selection.End(xlDown).Select
ActiveCell.Offset(0, -1).Range("A1").Select
Range(Selection, Selection.End(xlUp)).Select
ActiveCell.Offset(-7951, 0).Range("A1:A7951").Select
ActiveCell.Activate
ActiveSheet.Paste
End Sub
Kindly copy the below code to the worksheet.
Private Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
If Target.Address = "$A$1" And Target.Count = 1 And Target.HasFormula Then
Dim lastRow As Long
lastRow = Range("A65000").End(xlUp).Row
Dim rng As Range
Set rng = Range("A2:A" & lastRow)
' Target.Copy
' rng.PasteSpecial xlPasteFormulas
'OR
' rng.Formula = Target.Formula
' OR
rng.FormulaR1C1 = Target.FormulaR1C1
End If
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
End Sub
I'm not sure if your end cell is always going to be the same, meaning you may want to "un" hard code the rows, but you could try this.
Sub test()
Range(Cells(1, 1), Cells(7951, 1)) = "=LEFT(RC[1],3)"
End Sub
If you are always going to put equations in column A based on the number of rows used in column B you could try this.
Sub test()
' dimension the variable type
Dim lastRow As Long
' select cell "B1"
Cells(1, 2).Select
' jump to the last consecutive row in column B
Selection.End(xlDown).Select
' collect the row number into a variable
lastRow = ActiveCell.Row
' paste the equation into the variable length range
Range(Cells(1, 1), Cells(lastRow, 1)) = "=LEFT(RC[1],3)"
End Sub
Thanks Todd and user2063626,
I decided on a simpler approach. I only needed to obtain the last row in order to set my selection area; the number of the last row is not used in the actual values to be written. The files to be manipulated are flat ascii exports; the column layout is constant, only the number of rows is variable.
After writing the formula to A1, I move down column B and test for a value one cell at a time; if TRUE, copy the formula to the left adjacent cell; if FALSE, end process.
Sub FillClientCodes()
Range("A1").Select
ActiveCell.FormulaR1C1 = "=LEFT(RC[1],3)"
ActiveCell.Select
Selection.Copy
ActiveCell.Offset(0, 1).Select
ActiveCell.Offset(1, 0).Select
CheckCell:
ActiveCell.Activate
If ActiveCell.Value <> 0 Then
ActiveCell.Offset(0, -1).Select
ActiveCell.Activate
ActiveSheet.Paste
ActiveCell.Offset(0, 1).Select
ActiveCell.Offset(1, 0).Select
GoTo CheckCell
Else: GoTo EndOfData
End If
EndOfData:
End Sub
It's not elegant - it runs slower than a single select and paste - but it works, and it will work on all the files I need to process. Thanks again.