So I have to loop through a range of about 10000 cells containing strings and shortening them to 255 characters. My actual code is like this:
For i = firstRow to lastRow
Range("X" & i) = Left(Range("X" & i),255)
Next i
However, this is extremely slow, so I was wondering if there was anyway to do that once on the whole range instead of looping through each cell of the range, or if there was any other way that is more efficient than doing it my way.
Try this:
Sub short()
Dim arr, FirstRow As Long, LastRow As Long, i As Long
arr = ThisWorkbook.Sheets("yoursheetname").Range("X" & FirstRow, "X" & LastRow).Value
For i = 1 To UBound(arr)
arr(i, 1) = Left(arr(i, 1), 255)
Next i
ThisWorkbook.Sheets("yoursheetname").Range("X" & FirstRow, "X" & LastRow).Value = arr
End Sub
When you work with thousands of rows or cells, arrays are the best way to go.
You try:
Option Explicit
Sub test()
Dim Lastrow As Long, FirstRow, i As Long
With ThisWorkbook.Worksheets("Sheet1")
Lastrow = .Cells(.Rows.Count, "X").End(xlUp).Row
FirstRow = 1
For i = FirstRow To Lastrow
.Range("X" & i).Value = Left(.Range("X" & i).Value, 255)
Next i
End With
End Sub
Or
Option Explicit
Sub test()
Dim Lastrow As Long, FirstRow
Dim rng As Range, cell As Range
With ThisWorkbook.Worksheets("Sheet1")
Lastrow = .Cells(.Rows.Count, "X").End(xlUp).Row
FirstRow = 1
Set rng = .Range(.Cells(FirstRow, 24), Cells(Lastrow, 24))
For Each cell In rng
cell.Value = Left(cell.Value, 255)
Next cell
End With
End Sub
Or this:
With ActiveSheet.Range("X" & firstRow & ":X" & lastRow)
.Value = .Parent.Evaluate("LEFT(" & rng.Address & ",255)")
End With
Related
I need to auto number rows if adjacent cell is not blank using VBA.
any one from below codes works perfectly , except if it counter blank cells.
as always, your support is much appreciated.
this the expected output
Sub Fill_Serial_Numbers_Option1()
Dim LastRow As Long
LastRow = Cells(Rows.count, "B").End(xlUp).Row
If LastRow > 2 Then
Range("A3:A" & Application.Max(2, LastRow)) = Evaluate("ROW(A1:A" & LastRow & ")")
End If
End Sub
Sub Fill_Serial_Numbers_Option2()
Dim LastRow As Long
LastRow = Cells(Rows.count, "B").End(xlUp).Row
If LastRow > 2 Then
With Range("A3:A" & LastRow)
.Cells(1, 1).value = 1
.DataSeries Rowcol:=xlColumns, Type:=xlLinear, Step:=1, Trend:=False
End With
End If
End Sub
Please, test the next code:
Sub testCountNonBlanks()
Dim sh As Worksheet, lastR As Long, arr, arrA, count As Long, i As Long
Set sh = ActiveSheet
lastR = sh.Range("B" & sh.rows.count).End(xlUp).row: count = 1
If lastR <= 2 Then Exit Sub
arr = sh.Range("B2:B" & lastR).value 'place the range in an array for faster iteration
arrA = sh.Range("A2:A" & lastR).value
For i = 1 To UBound(arr)
If arr(i, 1) <> "" Then arrA(i, 1) = count: count = count + 1
Next i
sh.Range("A2").Resize(UBound(arrA), 1).value = arrA
End Sub
If a formula (written in VBA) is allowed, you can use the next variant:
Sub testCountByFormula()
Dim sh As Worksheet, lastR As Long, rngB As Range
Set sh = ActiveSheet
lastR = sh.Range("B" & sh.rows.count).End(xlUp).row
Set rngB = sh.Range("B2:B" & lastR)
sh.Range("A2:A10").Formula = "=IF(B2<>"""",COUNTA(" & rngB.Address & ")-COUNTA(" & rngB.Address(0, 1) & ")+1,"""")"
End Sub
You don't need a macro to accomplish this. Assuming all you care about is blank or not, then you can use a formula like this in cell A9. =Counta($B$1:$B9) If you have formulas you can try to leverage something with COuntif.
You can use a loop from the first row to the last one, something like this:
Sub Fill()
Dim LastRow As Long
Dim Count As Integer
Dim Row As Integer
Count = 0
Row = 1
LastRow = Cells(Rows.Count, "B").End(xlUp).Row
Do While Row <= LastRow
If Not (Cells(Row, 2) = "") Then
Count = Count + 1
Cells(Row, 1) = Count
End If
Row = Row + 1
Loop
End Sub
I have created below code which works like IF Col"B" any cell <> "" And Col"L" any cell = "Leop" then add row below to the active cell.
I mean I'm trying to achieve is to insert single row after certain row which contain in column B any value, and if column L in same row contains value = "Leop". Then add the row after that certain row.
But an error is appear. Compile Error: Invalid use of property on xlDown
Your help will be appreciated to fix it.
From this:
to this:
Sub firstcondition()
Dim ws As Worksheet
Dim LRow As Long
Dim rng As Range
Dim rng2 As Range
Dim i As Long
Dim p As Long
Dim dat As Variant
Dim datt As Variant
Dim IRow As Long
Set ws = Thisworkbooks.Sheets("Sheet2")
With ws
LRow = .Range("A" & .Rows.Count).End(xlUp).Row
Set rng = .Range("B2:B" & LRow)
Set rng2 = .Range("L2:L" & LRow)
dat = rng
datt = rng2
IRow = Selection.Row
For i = LBound(dat, 1) To UBound(dat, 1)
For p = LBound(datt, 1) To UBound(datt, 1)
If dat(i, 1) <> "" And datt(p, 1) = "Leop" Then
Rows(IRow + 1).Select
Selection.Insert Shift: xlDown
End If
End Sub
It will be like in formula:
IF(AND(B2<>"",L2="Leop"),"InsertRowBelow to Row 2 If condition is met","")
and will drag it down to the lastRow.
Thisworkbooks.Sheets("Sheet2") should be Thisworkbook.Sheets("Sheet2") and missing = in Selection.Insert Shift:= xlDown
Inserting or deleting rows will change the last row number so start at the bottom and work upwards.
Option Explicit
Sub firstcondition()
Dim ws As Worksheet, LRow As Long, r As Long
Dim n As Long
Set ws = ThisWorkbook.Sheets("Sheet2")
With ws
LRow = .Range("B" & .Rows.Count).End(xlUp).Row
For r = LRow To 2 Step -1
If .Cells(r, "B") <> "" And .Cells(r, "L") = "Leop" Then
.Rows(r + 1).Insert shift:=xlDown
n = n + 1
End If
Next
End With
MsgBox n & " rows inserted", vbInformation
End Sub
Try this with autofilter, you dont have to loop through each row. So it will work faster for larger data.
Option Explicit
Sub firstcondition()
Dim ws As Worksheet
Dim LRow As Long, cl As Range
Set ws = ThisWorkbook.Sheets("Sheet2")
LRow = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
ws.Range("L1:L" & LRow).AutoFilter 1, "Leop"
For Each cl In ws.Range("_FilterDatabase").SpecialCells(12).Cells
If ws.Range("B" & cl.Row) <> "" Then
cl.Offset(1).EntireRow.Insert Shift:=xlDown
End If
Next
ws.AutoFilterMode = False
End Sub
Sub MS()
Data = Sheets("Tabelle1").Select
Rows("1:1").Select
Rows("11409:11409").Select
Dim bilder As Long
Dim n As Long
Dim d As Long
Dim t As Long
bilder = 64
n = 1
d = 0
t = 0
'Dim i As Long
'For i = 1 To lastrow
Range("a1:a" & Cells(Rows.Count, 1).End(xlUp).Row).Select
Range("b1:b" & Cells(Rows.Count, 1).End(xlUp).Row).Select
'Range("a1").Select
'Range("b1").Select
Range("a1,b1").Select
Do While ActiveCell.Value <> ""
Radius = Sqr(Range("A1").Value * Range("A1").Value + Range("B1").Value * Range("B1").Value)
ActiveCell.Offset(1, 1).Select
Loop
End Sub
I'm not sure why you'd want to do it this way (given that it can be done with a simple formula in-cell), but looking at the remnants of code in your question we can see what you're trying to achieve. Here's how I'd do it:
Sub MS()
Dim sht As Worksheet, StartRow As Long, LastRow As Long, OutputColumn As Long
Dim SideA As Double, SideB As Double, SideC As Double
With Worksheets("Tabelle1")
'Set StartRow to the first row of your data ignoring headers
StartRow = 2
'Locate LastRow as last occupied cell in column A
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
'Set OutputColumn to 3
OutputColumn = 3
'Start loop
For r = StartRow To LastRow
SideA = .Cells(r, 1).Value
SideB = .Cells(r, 2).Value
SideC = Sqr(SideA * SideA + SideB * SideB)
.Cells(r, OutputColumn).Value = SideC
Next
End With
End Sub
Output:
You do not need to select the range to work with it. You may want to see How to avoid using Select in Excel VBA
In your code you are not writing the output to any cell. Here are two ways that will help you achieve what you want.
NON VBA - WAY 1
Put the formula =SQRT(A1*A1+B1*B1) or =SQRT(A1^2+B1^2) in C1 and drag it down
VBA - WAY 2 (Without Looping)
Option Explicit
Sub Sample()
Dim ws As Worksheet
Dim lRow As Long
Set ws = Sheets("Tabelle1")
With ws
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
With .Range("C1:C" & lRow)
.Formula = "=SQRT(A1*A1+B1*B1)"
.Value = .Value
End With
End With
End Sub
VBA - WAY 3 (Without Looping) Slightly complicated way of doing this. Explanation can be seen HERE
Option Explicit
Sub Sample()
Dim ws As Worksheet
Dim lRow As Long
Set ws = Sheets("Tabelle1")
With ws
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
With .Range("C1:C" & lRow)
.Value = Evaluate("index(SQRT((A1:A" & lRow & _
")^2+(B1:B" & lRow & _
")^2),)")
End With
End With
End Sub
I'm wanting to clear a cell contents of a range based.
I think I'm nearly there.
Dim R As Range
Dim myRange As Range
LastRow = Range("A" & Rows.Count).End(xlUp).Row
Set myRange = Range("Y2:Y" & LastRow)
For Each R In myRange
If R = 0 Then
cell.ClearContents
End If
Next
End Sub
All help appreciated.
The problem is your cell reference. Change cell. to R. R is the cell in the range that you are looping through so if R = 0, clear it.
Sub clearR()
Dim R As Range
Dim myRange As Range
lastRow = Range("A" & rows.count).End(xlUp).Row
Set myRange = Range("Y2:Y" & lastRow)
For Each R In myRange
If R = 0 Then
R.ClearContents
End If
Next
End Sub
Another Solution without a loop if column Y is not formula then this should work.
Sub clearR()
Dim LastRow As Long
LastRow = Range("A" & Rows.Count).End(xlUp).Row
Range("Y2:Y" & LastRow).Replace 0, "", xlWhole
End Sub
You could use:
Sub Macro1()
Dim LastRow As Long
With ThisWorkbook.Worksheets("Sheet1")
'Find last row
LastRow = .Range("A" & .Rows.Count).End(xlUp).Row
'Clear replace 0 with nothing in the specific range
.Range("Y2:Y" & LastRow).Replace What:="0", Replacement:="", LookAt:=xlWhole
End With
End Sub
I'm a novice trying to learn VBA. I've got a looping question: I have a simple set of numbers that are grouped in rows of three. I'm hoping to sum them up individually in column f. How could I create a dynamic range in order to loop through these to get the totals?
layout and workings are below - I don't think I have my dynamic range formula correct either. Any help is gratefully appreciated:
basic test data
Sub testing1000b()
Dim rng As Range
Dim lAnswer As Long
Dim lastrow As Long
Dim firstrow As Long
Dim addrow As Long
Range("e:f").ClearContents
addrow = 6
firstrow = Range("b" & addrow).Row
lastrow = Range("b" & firstrow).End(xlDown).Row
Range("b & firstrow" & "b & lastrow") = rng
lAnswer = WorksheetFunction.Sum(rng)
Range("f6").Value = lAnswer
End Sub
Sum Up Consecutive Cells
Sub SumConsecutive()
Const SourceCol As Long = 2
Const ResultCol As Long = 6
Const InitialRow As Long = 6
Const Consecutive As Long = 3
Dim rng As Range
Dim FirstRow As Long
Dim LastRow As Long
Dim Result As Long
Dim RowDiff As Long
Columns(ResultCol).ClearContents
FirstRow = InitialRow
LastRow = Cells(FirstRow, SourceCol).End(xlDown).Row
RowDiff = LastRow - FirstRow
Do Until RowDiff <> Consecutive - 1
Set rng = Range(Cells(FirstRow, SourceCol), Cells(LastRow, SourceCol))
Result = WorksheetFunction.Sum(rng)
Cells(FirstRow, ResultCol).Value = Result
FirstRow = Cells(LastRow, SourceCol).End(xlDown).Row
LastRow = Cells(FirstRow, SourceCol).End(xlDown).Row
RowDiff = LastRow - FirstRow
Loop
MsgBox "Done"
End Sub
You can create a dynamic range with the code bellow.
You need to use [Set] when object is assigned to a variable.
Set rng = Range("b" & firstrow & ":" & "b" & lastrow)
this is a sample code.
Sub testing1000b()
Dim rng As Range
Dim lAnswer As Long
Dim lastrow As Long
Dim firstrow As Long
Dim addrow As Long: addrow = 6
Range("e:f").ClearContents
firstrow = Range("b" & addrow).Row
lastrow = Range("b" & firstrow).End(xlDown).Row
For i = 0 To 3
Set rng = Range("b" & firstrow & ":" & "b" & lastrow)
Range("f" & firstrow) = WorksheetFunction.Sum(rng)
firstrow = Range("b" & lastrow).End(xlDown).Row
lastrow = Range("b" & firstrow).End(xlDown).Row
Next i
End Sub