Copy and Paste row by index number in Excel Macro - vba

I'm trying to copy an entire row by index number and paste it to another row with a different index number when a certain condition is met (I know the issue is not with the conditional logic). I'm thinking of something like this:
Sub Makro1()
Dim i As Integer
With ActiveSheet
'for looping
totalRows = .Cells(.Rows.Count, "A").End(xlUp).Row
'index of last row even after rows have been added
lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
'data starts at row #3
For i = 3 To totalRows
If .Cells(i, 19).Value > 0 Then
Number = .Cells(i, 19).Value
Do While Number > 0
lastRow = lasRow + 1
'Next line doesnt do anything
.Rows(lastRow) = .Rows(i).Value
Number = Number - 1
Loop
End If
Next i
End With
End Sub
The logic works like its supposed to but no lines are pasted. I've gone step by step and am certain the problem is not with the logic.

I assume that you want to copy Rows(i) and paste it as value in Rows(lastRow). So, you need to replace this line
.Rows(lastRow) = .Rows(i).Value
with these two lines:
.Rows(i).Copy
.Rows(lastRow).PasteSpecial xlPasteValues
Or
.Rows(lastRow).Copy
.Rows(i).PasteSpecial xlPasteValues
if you want to copy Rows(lastRow) and paste it as value in Rows(i).
Edit:
To paste everything (formulas + values + formats), use paste type as xlPasteAll.
Reference: msdn

Range Copy and Paste
Syntax
Range().Copy [Destination]
The square brackets indicate that Destination is an optional parameter. If you don't designate a Destination range it copies the selection to the clipboard. Otherwise it copies the first range directly to the new location.
Change this line:
.Rows(lastRow) = .Rows(i).Value
To:
.Rows(lastRow).copy .Rows(i)
It's worth noting that
.Rows(lastRow).copy .Cells(i, 1)
Will also work. Excel will resize the Destination range to fit the new data.

your code works for me
so just add a breakpoint at .Rows(lastRow) = .Rows(i).Value statement and then query all relevant variables value in the Immediate Window, like:
?lastRow
?.Rows(lastRow).Address
?i
?.Rows(i).Address
in the meanwhile you could
add Option Explicit statement at the very top of your code module
this will force you to declare all variables and thus lead to some extra work, but you'll get repaid with much more control over your variables usage and misspelling, thus saving debugging time
dim variables to hold rows index as of Long type, to handle rows index higher then 32767
avoid inner loop using the Resize() method of range object
much like follows:
Option Explicit
Sub Makro1()
Dim i As Long, totalRows As Long, lastRow As Long, Number As Long
With ActiveSheet
'for looping
totalRows = .Cells(.Rows.Count, "A").End(xlUp).Row
'index of row to add from
lastRow = totalRows + 1 '<--| start pasting values one row below the last non empty one in column "A"
'data starts at row #3
For i = 3 To totalRows
If .Cells(i, 19).Value > 0 Then
Number = .Cells(i, 19).Value
.Rows(lastRow).Resize(Number).Value = .Rows(i).Value
lastRow = lastRow + Number
End If
Next i
End With
End Sub

Related

How do i copy rows from another sheet and paste them into a sheet that has a table in it?

I am working on a code and all I want to do is copy data from one sheet and paste it into another sheet that has a table setup.
My code is doing exactly what I want it to do but, the table doesn't resize to include all the rows that was copied, only the first row of the copied data goes into the table. and the rest are formatted as not in the table.
This is how it looks like after I run the code
Sub LastRowInOneColumn()
Dim LastRow As Longenter image description here
Dim i As Long, j As Long
'Find the last used row in a Column
With Worksheets("First Page")
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
'first row number where you need to paste values in Sheet1'
With Worksheets("Report")
j = .Cells(.Rows.Count, "A").End(xlUp).Row '+ 1
End With
For i = 1 To LastRow
With Worksheets("First Page")
'If .Cells(i, 1).Value = "X" Then
.Rows(i).Copy Destination:=Worksheets("Report").range("A" & j)
j = j + 1
'End If
End With
Next i
End Sub
Usually, inserting below the end of the table will make it grow automatically, but not when pasting a range that exceeds the number of columns in the table. There are two ways to deal with this:
1- limit the copied range to the number of columns in the table; i.e.
.Rows(i).Resize(,4).Copy Destination:=Worksheets("Report").range("A" & j)
' ^^^^^^^^^^^
2- Explicitly resizing the table, using the method ListObject.Resize; i.e.
With Sheet1.ListObjects(1)
.Resize .Range.Resize(.Range.Rows.count + 1)
End With

VBA - find values in columns and insert blank rows in front of those cells

I want to find cells, which contain an exact value and insert in front of those cells blank rows. I already have code, which will find and insert those rows, but only behind those cells.
The code is here:
Private Sub SearchnInsertRows()
Dim LastRow As Long
Dim rng As Range, C As Range
Dim vR(), n As Long
With Worksheets("INPUT_2") ' <-- here should be the Sheet's name
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row ' last row in column A
Set rng = .Range("A1:A" & LastRow) ' set the dynamic range to be searched
' loop through all cells in column A and copy below's cell to sheet "Output_2"
For Each C In rng
If C.Value = "Workflow" Then
.Range(Cells(C.Row + 1, 1), Cells(C.Row + 8, 8)).EntireRow.Insert
End If
Next C
End With
End Sub
This code will add 8 rows behind all cells, which contain word "Workflow", but I cannot figure it out, how to put them in front of cells "Workflow"
I thought, that when I put - instead of +, it should solve it, but when I change this line this way:
.Range(Cells(C.Row - 1, 1), Cells(C.Row - 8, 8)).EntireRow.Insert
and run it, the excel will stuck and still adding rows.
Could I ask you for an advice, what do I do incorrectly, please?
Many thanks
Instead of an For Each loop use a For i = LastRow to 1 Step -1 loop to loop backwards from last row to first. Inserting or deleting rows has always to be done backwards (from bottom to top) because then it will only affect rows that are already processed otherwise the row-counts of unprocessed rows will change and mess up the loop.
Something like the following should work:
Option Explicit 'Very first line in a module to enforce correct variable declaring.
Private Sub SearchAndInsertRows()
Dim lRow As Long, iRow As Long
With Worksheets("INPUT_2") ' <-- here should be the Sheet's name
lRow = .Cells(.Rows.Count, "A").End(xlUp).Row ' last row in column A
'loop backwards (bottom to top = Step -1) through all rows
For iRow = lRow To 1 Step -1
'check if column A of current row (iRow) is "Workflow"
If .Cells(iRow, "A").Value = "Workflow" Then
.Rows(iRow).Resize(RowSize:=8).Insert xlShiftDown
'insert 8 rows and move current (iRow) row down (xlShiftDown)
'means: insert 8 rows ABOVE current row (iRow)
'.Rows(iRow + 1).Resize(RowSize:=8).Insert xlShiftDown
'alternatively use .Rows(iRow + 1) to insert BELOW current row (iRow)
End If
Next iRow
End With
End Sub

Sum Values based on unique ID

Just started a new job. I'm automating a month-end report and I'm new at VBA. Been googling most of my issues with success, but I've finally run into a wall. In essence I'm downloading some data from SAP and from there I need to build a report.
My question is: How to do a sumif function using loops in VBA?
Data pull:
Sheet1 contains a product code and purchase amounts (columns A & B) respectively. One product code can have several purchases (several rows with the same product code).
Steps so far:
I arranged the data sheet1 to be in ascending order.
Copied unique values for the product codes onto another sheet (sheet2). So Sheet2 has a list of all the products (in ascending order).
I want to get the sum of all purchases in sheet2 column B (per product code). I know how to do this using formulas, but I need to automate this as much as possible. (+ I'm genuinely interested in figuring this out)
This is what I did in VBA so far:
Sub Macro_test()
Dim tb As Worksheet
Dim tb2 As Worksheet
Dim x As Integer
Dim y As Integer
Dim lrow As Long
Set tb = Sheets("sheet1")
Set tb2 = Sheets("sheet2")
lrow = tb.Cells(Rows.Count, "A").End(xlUp).Row
For x = 2 To lrow
For y = 2 To lrow
If tb2.Cells(x, 1).Value = tb.Cells(y, 1).Value Then
tb2.Cells(x, 2).Value = tb.Cells(y, 2).Value
End If
Next y
Next x
End Sub
If i'm not mistaken, for each product_code in sheet2 col A, I'm looping through all the product codes in sheet1 and getting back the LAST value it finds, instead of the sum of all values... I understand why it doesn't work, I just don't know how to fix it.
Any help would be much appreciated. Thanks!
This statement overwrites the value of tb2.Cells(x, 2).Value at each iteration:
tb2.Cells(x, 2).Value = tb.Cells(y, 2).Value
Instead, I think you need to keep adding to it:
tb2.Cells(x, 2).Value = tb2.Cells(x, 2).Value + tb.Cells(y, 2).Value
But I don't like the looks of your double-loop which uses only one lrow variable to represent the "last row" on the two different worksheets, that could be causing some issues.
Or, in your loop do something like this which I think will avoid the duplicate sum. Still, assumes the second worksheet doesn't initially have any value in
' Base our lRow on Sheet2, we don't care how many rows in Sheet1.
lrow = tb2.Cells(tb2.Rows.Count, 1).End(xlUp).Row
Dim cl as Range
Set cl = tb.Cells(2,1) 'Our initial cell value / ID
For x = 2 to lRow '## Look the rows on Sheet 2
'## Check if the cell on Sheet1 == cell on Sheet2
While cl.Value = tb2.Cells(x,1).Value
'## Add cl.Value t- the tb2 cell:
tb2.Cells(x, 2).Value = tb2.Cells(x, 2).Value + cl.Offset(0,1).Value
Set cl = cl.Offset(1) '## Reassign to the next Row
Wend
Next
But it would be better to omit the double-loop and simply use VBA to do 1 of the following:
1. Insert The Formula:
(See Scott Holtzman's answer).
This approach is better for lots of reasons, not the least of which is that the WorksheetFunction is optimized already, so it should arguably perform better though on a small dataset the difference in runtime will be negligible. The other reason is that it's stupid to reinvent the wheel unless you have a very good justification for doing so, so in this case, why write your own version of code that accomplishes what the built-in SumIf already does and is specifically designed to do?
This approach is also ideal if the reference data may change, as the cell formulas will automatically recalculate based on the data in Sheet1.
2. Evaluate the formula & replace with values only:
If you prefer not to retain the formula, then a simple Value assignment can remove the formula but retain the results:
With .Range(.Range("B2"), .Range("A2").End(xlDown).Offset(, 1))
.FormulaR1C1 = "=SUMIF(Sheet1!C[-1]:C[-1],RC[-1],Sheet1!C:C)"
.Value = .Value 'This line gets rid of the formula but retains the values
End With
Use this approach if you will be removing Sheet1, as removing the referents will break the formula on Sheet2, or if you otherwise want the Sheet2 to be a "snapshot" instead of a dynamic summation.
If you really need this automated, take advantage of VBA to place the formula for you. It's very quick and easy using R1C1 notation.
Complete code (tested):
Dim tb As Worksheet
Dim tb2 As Worksheet
Set tb = Sheets("sheet1")
Set tb2 = Sheets("sheet2")
Dim lrow As Long
lrow = tb.Cells(tb.Rows.Count, 1).End(xlUp).Row
tb.Range("A2:A" & lrow).Copy tb2.Range("A2")
With tb2
.Range("A2").CurrentRegion.RemoveDuplicates 1
With .Range(.Range("B2"), .Range("A2").End(xlDown).Offset(, 1))
.FormulaR1C1 = "=SUMIF(Sheet1!C[-1]:C[-1],RC[-1],Sheet1!C:C)"
End With
End With
Note that with R1C1 notation the C and R are not referring to column or row letters . Rather they are the column and row offsets from the place where the formula is stored on the specific worksheet. In this case Sheet!C[-1] refers to the entire A column of sheet one, since the formula is entered into column B of sheet 2.
I wrote a neat little algorithm (if you can call it that) that does what you want them spits out grouped by totals into another sheet. Basically it loops through the first section to get unique names/labels and stores them into an array. Then it iterates through that array and adds up values if the current iteration matches what the current iteration of the nested loop position.
Private Sub that()
Dim this As Variant
Dim that(9, 1) As String
Dim rowC As Long
Dim colC As Long
this = ThisWorkbook.Sheets("Sheet4").UsedRange
rowC = ThisWorkbook.Sheets("Sheet4").UsedRange.Rows.Count
colC = ThisWorkbook.Sheets("Sheet4").UsedRange.Columns.Count
Dim thisname As String
Dim i As Long
Dim y As Long
Dim x As Long
For i = LBound(this, 1) To UBound(this, 1)
thisname = this(i, 1)
For x = LBound(that, 1) To UBound(that, 1)
If thisname = that(x, 0) Then
Exit For
ElseIf thisname <> that(x, 0) And that(x, 0) = vbNullString Then
that(x, 0) = thisname
Exit For
End If
Next x
Next i
For i = LBound(that, 1) To UBound(that, 1)
thisname = that(i, 0)
For j = LBound(this, 1) To UBound(this, 1)
If this(j, 1) = thisname Then
thisvalue = thisvalue + this(j, 2)
End If
Next j
that(i, 1) = thisvalue
thisvalue = 0
Next i
ThisWorkbook.Sheets("sheet5").Range(ThisWorkbook.Sheets("Sheet5").Cells(1, 1), ThisWorkbook.Sheets("Sheet5").Cells(rowC, colC)).Value2 = that
End Sub
Yay arrays

Applying VBA RIGHT to an entire column - Infinite Loop Issue

I have data that I am working to Parse Out that I have imported from approval emails sent in Outlook. At this point I am just importing the CreationTime and the SubjectLine.
For the subject line I am able to use the Split function to separate out most of the data. I then am left with Job Codes in Column B and Position numbers in Column C which includes the text: "Job Codes: XXXX" and the four digit job code number and "PN XXXX" and either a four digit or 6 digit position number. I am trying to use the Right functionality to loop through the entire column and reformat the column just to show only the four digit job code number for Column B and either just the 4 digit or 6 digit position number (the actual numbers) for Column C
For Job Code Column B:
Currently my code works for Shortening the Job Codes but it involves adding a column, putting the RIGHT formula in that column for the shortened Job Code, then copying and pasting the formula as values back into the column and then deleting the original column.
The problem- Works but perhaps not the most efficient with a larger data set (currently 200 rows but will have 2000 or more)
Code:
Sub ShortenJobCodes()
Application.ScreenUpdating = False
Const R4Col = "=RIGHT(RC3,4)"
Dim oRng As Range
Dim LastRow As Long
Range("B1").EntireColumn.Insert
LastRow = Cells(Rows.Count, "A").End(xlUp).Row
Set oRng = Range("B:B")
Range(oRng, Cells(LastRow, "B")).FormulaR1C1 = R4Col
Set oRng = Nothing
Columns("B").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues
Range("C1").EntireColumn.Delete
Application.ScreenUpdating = True
End Sub
For Position Numbers Column C:
Currently I have mirrored the above code but added in an if statement using LEN to count if the characters are less than 8, if so then insert one RIGHT function if not insert the other RIGHT function. This also involves adding an additional column putting the RIGHT formula in that column for the shortened Position Number(Eliminating all but just the number), then copying and pasting the formula as values back into the column and then deleting the original column.
Problem - This works but seems to take forever to process and in fact looks like it is in an infinite loop. When I Esc out of it, it does add the column and then input the proper RIGHT formula (leaving just the numeric values) but the sub never seems to end, nor does it copy and paste the formulas as values or delete the original column. As noted above I realize this is likely a more efficient way to do this but I have tried a bunch of options without any luck.
I am realizing part of the loop might be due to the range itself being an entire column but I cannot find a way to stop that with the last row (even though I have a count in there).
Code:
Sub ShortenPositionNumbers()
Application.ScreenUpdating = False
Const R4Col = "=RIGHT(RC4,4)"
Const R6Col = "=RIGHT(RC4,6)"
Dim oRng As Range
Dim rVal As String
Dim y As Integer
Dim selCol As Range
Dim LastRow As Long
Range("C1").EntireColumn.Insert
LastRow = Cells(Rows.Count, "A").End(xlUp).Row
Set selCol = Range("D:D")
For Each oRng In selCol
oRng.Select
rVal = oRng.Value
If Len(oRng.Value) > 8 Then
oRng.Offset(0, -1).FormulaR1C1 = R6Col
Else
oRng.Offset(0, -1).FormulaR1C1 = R4Col
End If
Next
Set oRng = Nothing
Columns("C").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues
Range("D1").EntireColumn.Delete
Application.ScreenUpdating = True
End Sub
Major Question: Is there a way to use RIGHT/TRIM/LEN/LEFT functions to do this within a cell without having to add columns/delete columns and insert functions?
There are a few things you can do here to speed up your code. I'm only going to reference the second code block as you can apply similar logic to the first.
The first issue is that you create a LastRow variable but never reference it again. It looks like you meant to use this in the selCol range. You should change that line to Set selCol = Range("C1:C" & lastRow). This way, when you loop through the rows you only loop through the used rows.
Next, in the For-Each loop you Select every cell you loop through. There really isn't any reason to do this and takes substantially longer. You then create the variable rVal but never use it again. A better way to set up the loop is as follows.
For Each oRng in selCol
rVal = oRng.Value
If Len(rVal) > 8 Then
oRng.Value = Right(rVal, 6)
Else
oRng.Value = Right(rVal, 4)
End If
Next
This is much cleaner and no longer requires creating columns or copying and pasting.
Try this, it uses Evaluate and no loops or added columns.
Sub ShortenPositionNumbers()
Application.ScreenUpdating = False
Dim selCol As Range
Dim LastRow As Long
With ActiveSheet
LastRow = .Cells(Rows.Count, "A").End(xlUp).Row
Set selCol = .Range(.Cells(1, 3), .Cells(LastRow, 3))
selCol.Value = .Evaluate("INDEX(IF(LEN(" & selCol.Address(0, 0) & ")>8,RIGHT(" & selCol.Address(0, 0) & ",6),RIGHT(" & selCol.Address(0, 0) & ",4)),)")
End With
Application.ScreenUpdating = True
End Sub
Or work with arrays
Sub ShortenPositionNumbers()
Dim data As Variant
Dim i As Long
With Range("C3:C" & Cells(Rows.Count, "A").End(xlUp).Row)
data = Application.Transpose(.Value)
For i = LBound(data) to UBound(data)
If Len(data(i)) > 8 Then
data(i) = RIGHT(data(i),6)
Else
data(i) = RIGHT(data(i),4)
End If
Next
.Value = Application.Transpose(data)
End With
End Sub

Copy cells in excel with vba

I have a code that reads in the new arrangement of columns from a text file and then rearrange the original columns by copying it in at the correct place, however there is a bug in my code. Instead of copying just 1 column it seems to copy all columns to the right of the column that i want to copy..
so i guess the error is here
'copy the old range
ws.Range(ws.Cells(Settings.rowHeader + 1, CounterCol), ws.Cells(lrow, CounterCol)).Copy
I want to copy the range AW3:AW80 to A3:A80, but do i need to copy AW:AW to A:A instead? If i do so the stuff in row 1 will be deleted, below is the full code:
Sub insertColumns()
Call Settings.init
Dim i As Integer
Dim ws As Worksheet
Dim lrow As Integer
Dim columNames As Object
Dim temp As Variant
'fill dictionary with columnnames from text file
Set columNames = FileHandling.getTypes(Settings.columnFile)
Set ws = ActiveWorkbook.Sheets("List")
'Get max column and row number
lColumn = HelpFunctions.getLastColumn(ws, Settings.rowHeader)
lrow = HelpFunctions.getLastRow(ws, HelpFunctions.getColumn("*part*", ws, Settings.rowHeader))
'Insert all new columns in reverse order from dictionary
temp = columNames.keys
For i = columNames.Count - 1 To 0 Step -1
ws.Columns("A:A").Insert Shift:=xlToRight
ws.Range("A" & Settings.rowHeader).Value = temp(i)
Next i
'last column
lastColumn = lColumn + columNames.Count
'we loop through old cells
CounterCol = columNames.Count + 1
Do While CounterCol <= lastColumn
j = 0
'through each elemnt in dictionary
For Each element In temp
j = j + 1
'compare the old rowheader with any of the rowheader in DICTIONARY
If UCase(ws.Cells(Settings.rowHeader, CounterCol).Value) = element Then
'copy the old range
ws.Range(ws.Cells(Settings.rowHeader + 1, CounterCol), ws.Cells(lrow, CounterCol)).Copy
'paste it
ws.Cells(Settings.rowHeader + 1, j).Select
ws.Paste
'format the new row
ws.Cells(Settings.rowHeader + 1, j).EntireColumn.AutoFit
'Delete the old row
ws.Columns(CounterCol).EntireColumn.Delete
'decrease the last column by one since we just deleted the last column
lastColumn = lastColumn - 1
found = True
'Exit For
End If
Next element
'Prompt the user that the old column does not match any of the new column
If Not found Then
MsgBox (UCase(ws.Cells(Settings.rowHeader, CounterCol)) & " was not a valid column name please move manually")
End If
'reset the found
found = False
'go to nect column
CounterCol = CounterCol + 1
Loop
End Sub
Below is a screenshot of the dictionary.
After the first iteration/first copy it should have only copied over the part number column, but as can been seen it has copied over more than just the first column(everything except of drawing number)
Q: I want to copy the range AW3:AW80 to A3:A80, but do i need to copy AW:AW to A:A instead?
A: No. Any range can be copied.
Rather than trying to debug your code, I'll give you a hint about how to debug such a thing. Lines like
ws.Range(ws.Cells(Settings.rowHeader + 1, CounterCol), ws.Cells(lrow, CounterCol)).Copy
are hard to debug because they are trying to do too much. You have 4 instances of the dot operator and suspected that the problem was with the last one (.Copy). The problem is almost certainly that your code isn't grabbing the range that you think it is grabbing. In other words, one or more of your method invocations earlier in the line needs debugging. In such a situation it is useful to introduce some range variables, set them equal to various values and print their addresses to the immediate window to see what is happening. As an added benefit, having set range variables allows you to use the full power of intellisence in the VBA editor. Something like:
Dim SourceRange As Range, Cell1 As Range, Cell2 As Range
'
'
'
Set Cell1 = ws.Cells(Settings.rowHeader + 1, CounterCol)
Set Cell2 = ws.Cells(lrow, CounterCol)
Set SourceRange = ws.Range(Cell1, Cell2)
Debug.Print Cell1.Address & ", " & Cell2.Address & ", " & SourceRange.Address
'
'Once the above is debugged:
'
SourceRange.Copy 'should work as expected
It is possible that you are copying the range that you want to copy but that your larger program still isn't working. In that case you have some sort of logic error and should be trying to copy some other range. Even then, the above exercise still helps because it makes it clear exactly what your original line was doing.
'go to nect column
CounterCol = CounterCol + 1
needed to be deleted. It has to do that the column shifts left when i deleted rows.
Thanks for the help. I hope the code can be used for others who might need to add columns, but still copy over content from old columnsin the right order.