So I'm trying to copy different columns up to the last row used and just loop through every range I'm trying to access. For this I declared an array that stores the first half of the range (fixed) and add the last row with & LastRow within the Range() but I always get an error Run-time error 9 Subscript out of range when looping through these ranges (the first row of the loop is marked). I just don't get why this isn't working (storing the & LastRow in the array doesn't work either). I need this LastRow to be variable since it's going to change in the later section of the macro.
Sub ImportRows()
Dim wbk As Workbook
Dim LastRow As Long
Dim CopiedColumns As Variant
Dim InsertColumns As Variant
Dim i As Integer
Set wbk = ActiveWorkbook
CopiedColumns = Array("A2:A", "C2:C", "F2:F", "J2:J", "L2:L")
'Copy Paste
'###########################################
InsertColumns = Array("A2:A", "B2:B", "C2:C", "D2:D", "E2:E")
With wbk.Worksheets("RawData")
LastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
End With
For i = 1 To 5
wbk.Worksheets("RawData").Range(CopiedColumns(i) & LastRow).Copy
wbk.Worksheets("Comparrisson").Range(InsertColumns(i) & LastRow).Insert
Next i
End Sub
Thanks for literally any help!
As I said in my comments, your code should work if the iteration is adapted to 1D arrays type. Please, test the next code, using only arrays and not involving the clipboard, slowing Excel and consuming more resources:
Sub ImportColumns()
Dim wbk As Workbook, LastRow As Long, CopiedColumns, InsertColumns As Variant
Dim sh As Worksheet, sh1 As Worksheet, i As Long, arrC
Set wbk = ActiveWorkbook
CopiedColumns = Array("A2:A", "C2:C") ', "F2:F", "J2:J", "L2:L")
Set sh = wbk.Worksheets("RawData")
Set sh1 = wbk.Worksheets("Comparrisson")
'Copy columns
'###########################################
InsertColumns = Array("A2", "B2", "C2", "D2", "E2")
LastRow = sh.cells(sh.rows.count, 1).End(xlUp).row
For i = 0 To 1
arrC = sh.Range(CopiedColumns(i) & LastRow)
sh1.Range(InsertColumns(i)).Resize(UBound(arrC), 1).value = arrC
Next i
End Sub
And a more compact solution, not involving any iteration:
Sub ImportColumnsArr()
Dim wbk As Workbook, LastRow As Long, arr, arrC
Dim sh As Worksheet, sh1 As Worksheet
Set wbk = ActiveWorkbook
Set sh = wbk.Worksheets("RawData")
Set sh1 = wbk.Worksheets("Comparrisson")
LastRow = sh.cells(sh.rows.count, 1).End(xlUp).row
arr = sh.Range("A2:L" & LastRow).value
arrC = Application.Index(arr, Evaluate("row(1:" & UBound(arr) & ")"), Array(1, 3, 5, 10, 12))
'Copy columns:
sh1.Range("A2").Resize(UBound(arrC), UBound(arrC, 2)).value = arrC
End Sub
Related
I need to select a Range from after Last Row till end of usedRange.
The below code works, But is there Proper /Shorter code.
Option Explicit
Sub Select_Blank_in_Usedrange()
Dim ws As Worksheet: Set ws = ActiveSheet
Dim LastR As Long, LastR_UsedRange As Long
LastR = ws.Cells(Rows.Count, "A").End(xlUp).Row
LastR_UsedRange = ws.UsedRange.Rows.Count
ws.Range("A" & LastR + 1, "AE" & LastR_UsedRange).Select
End Sub
If the code works and has no redundant parts, I would say it's good. If I were to suggest an improvement, it would be to save the relevant addresses as Range Objects instead of Row numbers. This way you can assemble the larger range directly from the two corners, instead of having to concatenate the address in the final step.
Sub Select_Blank_in_Usedrange()
Dim ws As Worksheet: Set ws = ActiveSheet
Dim TopCorner As Range
Set TopCorner = ws.Cells(ws.Rows.Count, "A").End(xlUp).Offset(1, 0)
Dim BottomCorner As Range
With ws.UsedRange.Columns(31)
Set BottomCorner = .Cells(.Cells.Count)
End With
ws.Range(TopCorner, BottomCorner).Select
End Sub
To me, this is much clearer, and the constants are clearly displayed. This will make it easier to edit later, if the number of columns changes, or if the starting column moves from "A".
The shortest code will be the next:
Dim ws As Worksheet: Set ws = ActiveSheet
ws.Range("A" & ws.Range("A" & ws.rows.count).End(xlUp).row + 1, _
"AE" & ws.UsedRange.rows.count + ws.UsedRange.cells(1).row - 1).Select
It will also deal with the case when UsedRange does not start from the first row...
Can you help me correct my VBA codes. I want to convert the values of Column U until the active row to Absolute Values meaning to remove the negative amounts.
Here is my VBA code:
Sub MakeColumnsAbsoluteValue()
Dim sht As Worksheet
Dim rngToAbs As Range
Dim LastRow As Long
Dim c As Range
Set sht = ThisWorkbook.Sheets("MJEBlackline")
LastRow = sht.Cells(sht.Rows, Count, "U").End(xlUp).Row
Set rngToAbs = Range("U5:U" & LastRow)
For Each c In rngToAbs
c.Value = Abs(c.Value)
Next c
End Sub
Problem with line LastRow = sht.Cells(sht.Rows, Count, "U").End(xlUp).Row
Use of , instead of . and not specifying the sheet reference in rngToAbs
Try:
Sub MakeColumnsAbsoluteValue()
Dim sht As Worksheet
Dim rngToAbs As Range
Dim LastRow As Long
Dim c As Range
Set sht = ThisWorkbook.Sheets("FF")
LastRow = sht.Cells(sht.Rows.count, "U").End(xlUp).row
Set rngToAbs = sht.Range("U5:U" & LastRow)
For Each c In rngToAbs
c.Value = Abs(c.Value)
Next c
End Sub
You may try:
Sub MakeColumnsAbsoluteValue()
Dim sht As Worksheet
Dim rngToAbs As Range
Dim LastRow As Long
Set sht = ThisWorkbook.Sheets("MJEBlackline")
With sht
LastRow = .Cells(.Rows.Count, "U").End(xlUp).Row
Set rngToAbs = .Range("U5:U" & LastRow)
rngToAbs.Value = .Evaluate("=abs(" & rngToAbs.Address & ")")
End With
End Sub
Or even (inspired through #GarysStudent):
Sub MakeColumnsAbsoluteValue()
Dim sht As Worksheet
Dim rngToAbs As Range
Dim LastRow As Long
Set sht = ThisWorkbook.Sheets("MJEBlackline")
With sht
LastRow = .Cells(.Rows.Count, "U").End(xlUp).Row
Set rngToAbs = .Range("U5:U" & LastRow)
rngToAbs.Replace what:="-", lookat:=xlPart, replacement:=""
End With
End Sub
This would both convert the whole range in one go. Assuming that's what you meant with:
"I want to convert the values of Column U until the active row..."
You could try:
Option Explicit
Sub MakeColumnsAbsoluteValue()
Dim sht As Worksheet
Dim rngToAbs As Range, c As Range
Dim LastRow As Long, x As Long
Dim arr() As Variant
Set sht = ThisWorkbook.Sheets("MJEBlackline")
x = 0
With sht
LastRow = .Cells(.Rows.Count, "U").End(xlUp).Row
Set rngToAbs = .Range("U5:U" & LastRow)
'Loop range and create an array including all abs values
For Each c In rngToAbs
ReDim Preserve arr(x)
arr(x) = Abs(c.Value)
x = x + 1
Next c
'Paste the values of the array at once instead of pasting values one by one
.Range("U5:U" & LastRow).Value = Application.WorksheetFunction.Transpose(arr)
End With
End Sub
I am beginning to learn how to use loops and arrays but this one has me stuck. Below is a code that loops through cells and adds them together in column P.
Sub Loop_Test()
Dim sht1 As Worksheet
Dim lr As Long
Dim i As Long
Set sht1 = Worksheets("Sheet1")
lr = Fcst.Cells(Rows.Count, "A").End(xlUp).Row
With sht1
For i = 4 To lr
.Range("P" & i).Value = Application.Sum(Range("D" & i, "O" & i))
Next
End With
End Sub
Overall, this code works but it is very slow and I need to apply it to thousands of rows. I know that in order to make this faster, I need to turn the sum range into an array but I am not entirely sure how to do this when a loop is included.
Any help would be greatly appreciated.
Thanks,
G
Disclaimer: I know there are more efficient ways to sum cells together but this is just me playing around and learning.
Just do them all at once. Looping only adds time to process individual iterations.
With sht1.Range(sht1.cells(4, "P"), sht1.cells(lr, "P"))
.formula = "=sum(D4:O4)"
.Value = .value
End With
Use a variant array to limit the number of times that the vba accesses the worksheets:
Sub Loop_Test()
Dim sht1 As Worksheet
Set sht1 = Worksheets("Sheet1")
Dim fcst As Worksheet
Set fcst = Worksheets("Sheet2")
Dim lr As Long
lr = fcst.Cells(Rows.Count, "A").End(xlUp).Row
Dim dta As Variant
dta = fcst.Range(fcst.Cells(4, "D"), fcst.Cells(lr, "O")).Value
Dim otpt As Variant
ReDim otpt(1 To UBound(dta, 1), 1 To 1)
With sht1
Dim i As Long
For i = LBound(dta, 1) To UBound(dta, 1)
otpt(i, 1) = Application.Sum(Application.Index(dta, i, 0))
Next i
.Range("P4").Resize(UBound(dta, 1), 1).Value = otpt
End With
End Sub
Edit
The SUM(INDEX()) is slow it is quicker just to add the parts individually.
Sub Loop_Test()
Dim sht1 As Worksheet
Set sht1 = Worksheets("Sheet1")
Dim fcst As Worksheet
Set fcst = Worksheets("Sheet2")
Dim lr As Long
lr = fcst.Cells(Rows.Count, "A").End(xlUp).Row
Dim dta As Variant
dta = fcst.Range(fcst.Cells(4, "D"), fcst.Cells(lr, "O")).Value
Dim otpt As Variant
ReDim otpt(1 To UBound(dta, 1), 1 To 1)
With sht1
Dim i As Long
For i = LBound(dta, 1) To UBound(dta, 1)
Dim j as Long
For j = lbound(dta,2) to ubound(dta,2)
otpt(i, 1) = otpt(i, 1) + dta(i, j)
Next j
Next i
.Range("P4").Resize(UBound(dta, 1), 1).Value = otpt
End With
End Sub
Tested on 50,000 rows and result was near instantaneous.
Rather than looping over each row you can insert a summation formula into each row of column P with a single line of code:
.Range("P4:P" & lr).Formula="=SUM(D4:O4)"
assuming 4 is the starting row, and your variable lr is the last row.
Faster With an Array
Sub Loop_Test()
Const cSheet1 As Variant = "Sheet1"
Const cSheet2 As Variant = "Sheet2"
Const fr As Integer = 4
Dim sht1 As Worksheet
Dim fcst As Worksheet
Dim lr As Long
Dim i As Long
Dim vnt As Variant
Set sht1 = Worksheets(cSheet1)
Set fcst = Worksheets(cSheet2)
With fcst
lr = .Cells(.Rows.Count, "A").End(xlUp).Row
ReDim vnt(1 To lr - fr + 1, 1 To 1)
For i = 1 To UBound(vnt)
vnt(i, 1) = WorksheetFunction.Sum( _
.Range("D" & i + fr - 1, "O" & i + fr - 1))
Next
End With
sht1.Cells(fr, "P").Resize(UBound(vnt)) = vnt
End Sub
I am currently trying to make a macro to pull all of the data from a specific row on my sales quote template workbook and then make it paste into the next available row on my quote logger workbook but im really struggling to find the right code to make it work. ive searched around but found nothing concrete that I could use.
what I have so far is below.
Option Explicit
Sub Test()
Dim sht1 As Worksheet, sht2 As Worksheet
Dim i As Long
Set sht1 = ThisWorkbook.Worksheets("Sheet1")
Set sht2 = "..............RAYOTEC LOGGER.xlsm"
For i = 2 To sht1.Cells(sht1.Rows.Count, "M").End(xlUp).Row
If sht1.Range("M" & i).Value = "No" Then
sht1.Range("A" & i).EntireRow.Cut sht2.Range("A" & sht2.Cells(sht2.Rows.Count, "M").End(xlUp).Row + 1)
End If
Next i
End Sub
Thanks in advance for any help
Change the part of your code before FOR loop with this,
Dim sht1 As Worksheet
Dim sht2 As Worksheet
Dim wb As Workbook
Dim i As Long
Set sht1 = ThisWorkbook.Worksheets("Sheet1")
Set wb = Application.Workbooks.Open("..............RAYOTEC LOGGER.xlsm")
Set sht2 = wb.Sheets("Sheet1")
Also you can use the below for the rest of the code as it just takes the values easily and deletes the row data that you do not need.
Dim sht1 As Worksheet
Dim sht2 As Worksheet
Dim i, n As Long
Dim iMx, nMx As Long
iMx = sht1.Cells(sht1.Rows.Count, "M").End(xlUp).Row
For i = 2 To iMx
nMx = sht2.Cells(sht2.Rows.Count, "A").End(xlUp).Row
If sht1.Range("M" & i).Value = "No" Then
sht2.Range("A" & nMx + 1).EntireRow.Value = sht1.Range("A" & i).EntireRow.Value
sht1.Range("A" & i).EntireRow.Delete Shift:=xlUp
i = i - 1
End If
Next i
I have this code, by a responder who helped me to define my needs yesterday - but there somethings i want to change, but my vba skills are very low and dont know how and where to modify the code. I want it do 2 Things.
Right know it transferes data, i want it to copy it, over with the values that are calculated in the cells. I have some cells, where i have some formulas and it dosent follows with it. I just want the calculated value over. I dont know if i can use xlPasteValues somewhere to get what i want?
The second thing that i want is, when copying over, i want to be on top and the previous copies move Down, so the latest copy always are in the top.
Thank you before handed :)
Option Explicit
Sub Copypastemeddata()
Dim wb As Workbook
Dim ws As Worksheet
Dim sourceCell As Range
Dim targetSheet As Worksheet
Set wb = ThisWorkbook
Set ws = wb.Worksheets("Opgørsel")
Set sourceCell = ws.Range("D3") 'Cell with sheet names for copying to
With ws
Set targetSheet = wb.Worksheets(sourceCell.Text)
Dim nextRow As Long
nextRow = GetLastRow(targetSheet, 1)
nextRow = IIf(nextRow = 1, 1, nextRow + 1)
.Range("A1").CurrentRegion.Copy targetSheet.Range("A" & nextRow)
targetSheet.Columns.AutoFit
End With
End Sub
Public Function GetLastRow(ByVal ws As Worksheet, Optional ByVal columnNumber As Long = 1) As Long
With ws
GetLastRow = .Cells(.Rows.Count, columnNumber).End(xlUp).Row
End With
End Function
Please give this a try...
The StartRow variable defines the destination row on targetSheet, you may change it as per your requirement.
Sub Copypastemeddata()
Dim wb As Workbook
Dim ws As Worksheet
Dim sourceCell As Range
Dim targetSheet As Worksheet
Dim StartRow As Integer
Application.ScreenUpdating = False
Set wb = ThisWorkbook
Set ws = wb.Worksheets("Opgørsel")
Set sourceCell = ws.Range("D3") 'Cell with sheet names for copying to
StartRow = 1 'Destination row on targetSheet
With ws
Set targetSheet = wb.Worksheets(sourceCell.Text)
.Range("A1").CurrentRegion.Copy
targetSheet.Range("A" & StartRow).Insert shift:=xlDown
targetSheet.Range("A" & StartRow).PasteSpecial xlPasteValues
targetSheet.Columns.AutoFit
End With
Application.CutCopyMode = 0
Application.ScreenUpdating = True
End Sub
substitute
Dim nextRow As Long
nextRow = GetLastRow(targetSheet, 1)
nextRow = IIf(nextRow = 1, 1, nextRow + 1)
.Range("A1").CurrentRegion.Copy targetSheet.Range("A" & nextRow)
with
With .Range("A1").CurrentRegion
targetSheet.Rows(1).Resize(.Rows.Count).Insert shift:=xlUp
targetSheet.Range("A1").Resize(.Rows.Count, .Columns.Count).Value = .Value
End With