insert copied cell values [vba] - vba

I have the following code it copies a certain range and paste inserts it in the next worksheet, but it copies formulas, I want it to insert the amount of rows copied and paste values only.
Sub create_payroll()
'copies values from 'Driver' Worksheet (till last row) and pastes values into Invoice Data A14
Dim LastRow As Long
Application.ScreenUpdating = False
LastRow = Worksheets("Driver").Cells(Rows.Count, "B").End(xlUp).Row
Sheets("Driver").Range("A3:H" & LastRow).Copy
Sheets("Invoice Data").Range("A14").Insert xlShiftDown

Or bypass the clipboard entirely:
Sheets("Invoice Data").Range("A14:H" & LastRow + 11).Value = Sheets("Driver").Range("A3:H" & LastRow).Value
To bypass the clipboard and insert rows use:
Sheets("Invoice Data").Rows("14:").Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Sheets("Invoice Data").Range("A14:H" & LastRow + 11).Value = Sheets("Driver").Range("A3:H" & LastRow).Value

Try using something like the following:
Sub create_payroll()
'copies values from 'Driver' Worksheet (till last row) and pastes values into Invoice Data A14
Dim LastRow As Long
Dim srcRng As Range
Application.ScreenUpdating = False
With Sheets("Driver")
LastRow = .Cells(.Rows.Count, "B").End(xlUp).Row
Set srcRng = .Range("A3:H" & LastRow)
End With
With Sheets("Invoice Data")
.Range("A14").Resize(srcRng.Rows.Count - 1, srcRng.Columns.Count).Insert shift:=xlDown
.Range("A14").Resize(srcRng.Rows.Count, srcRng.Columns.Count).Value = srcRng.Value
End With
End Sub

Related

Macro to copy-paste range in row to different sheets based on specific cell value

I have a workbook with 3 sheets: first one is the raw data sheet, then 2 target sheets. I would need a macro that would look at cell C in raw data sheet and based on the 2 values (YES or NO), will copy and paste the range A:Y in sheets 2, respectively 3.
Example: if on C2 in raw data sheet i have YES, copy A2:Y2 and paste into sheet 2, same range A2:Y2. If instead i have the value NO, copy A2:Y2 and paste into sheet 3.
Then go to next row and copy-paste A3:Y3 to sheet 2 if YES or A3:Y3 to sheet 3 if NO.
I wrote something that only works for the 2nd row, but i don't know how to make it loop... so basically when it passes to the next rows, it still copies the values from A2:Y2 to the target sheet, instead of copying A3:Y3, A4:Y4 etc..
Pasting my poor code below:
Sub IdentifyInfraction()
Dim rngA As Range
Dim cell As Range
Set rngA = Range("C2", Range("C65536").End(xlUp))
For Each cell In rngA
Worksheets("raw_data").Select
If cell.Value = "YES" Then
Range("A2:Y2").Copy
Worksheets("Value_YES").Select
Range("A2").PasteSpecial Paste:=xlPasteValues
ElseIf cell.Value = "NO" Then
Range("A2:Y2").Copy
Worksheets("Value_NO").Select
Range("A2").PasteSpecial Paste:=xlPasteValues
End If
Next cell
End Sub
Please help!!! :-s
Easiest solution would just be to replace the number 2 in each of your ranges to a variable which you then increment at the end your statement, before you go to the next cell.
For example:
Dim i = 2
Set rngA = Range("C2", Range("C65536").End(xlUp))
For Each cell In rngA
Worksheets("raw_data").Select
If cell.Value = "YES" Then
Range("A" & i & ":Y" & i).Copy
Worksheets("Value_YES").Select
Range("A" & i).PasteSpecial Paste:=xlPasteValues
ElseIf cell.Value = "NO" Then
Range("A" & i & ":Y" & i).Copy
Worksheets("Value_NO").Select
Range("A" & i).PasteSpecial Paste:=xlPasteValues
End If
i = i + 1
Next cell
So, originally we set i = 2, this is to go in line with your starting row of 2 mentioned in your question. Then, Range("A" & i & ":Y" & i).Copy is the same as saying Range("A2:Y2").Copy or Range("A3:Y3").Copy, etc.
This will go through any copy each row, a new row each time, and paste it to the respective row in the various sheets.
I hope this works for what you are trying to do, if not let me know.
There are a few things I'd also recommend looking into. There's a much better way to copy and paste, without going back and forward through the sheets.
ThisWorkbook.Sheets("raw_data").Rows(i).Copy Destination:=Worksheets("Value_YES").Range("A" & i)
Something like this would take the whole row from raw_data and transfer it to Value_YES. You'd have to mess around with it and change the range from Rows(i), but that's just an example.
I'd also recommend that you look into How to avoid using Select in Excel VBA to better understand why it's frowned upon to use Select and Activate in Excel VBA.
My version:
Sub GetR_Done()
Dim rng As Range, c As Range, LstRw As Long
Dim ws As Worksheet, Nr As Long, Yr As Long
Dim Ys As Worksheet, Ns As Worksheet
Set ws = Sheets("raw_data")
Set Ys = Sheets("Value_YES")
Set Ns = Sheets("Value_NO")
With ws
LstRw = .Cells(.Rows.Count, "C").End(xlUp).Row
Set rng = .Range("C2:C" & LstRw)
For Each c In rng.Cells
If c = "YES" Then
With Ys
Yr = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
End With
.Range(.Cells(c.Row, "A"), .Cells(c.Row, "Y")).Copy Ys.Range("A" & Yr)
End If
If c = "NO" Then
With Ns
Nr = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
End With
.Range(.Cells(c.Row, "A"), .Cells(c.Row, "Y")).Copy Ns.Range("A" & Nr)
End If
Next c
End With
End Sub
If you really require to paste values, then use this one
Sub GetR_Done()
Dim rng As Range, c As Range, LstRw As Long
Dim ws As Worksheet, Nr As Long, Yr As Long
Dim Ys As Worksheet, Ns As Worksheet
Set ws = Sheets("raw_data")
Set Ys = Sheets("Value_YES")
Set Ns = Sheets("Value_NO")
Application.ScreenUpdating = False
With ws
LstRw = .Cells(.Rows.Count, "C").End(xlUp).Row
Set rng = .Range("C2:C" & LstRw)
For Each c In rng.Cells
If c = "YES" Then
With Ys
Yr = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
End With
.Range(.Cells(c.Row, "A"), .Cells(c.Row, "Y")).Copy
Ys.Range("A" & Yr).PasteSpecial xlPasteValues
End If
If c = "NO" Then
With Ns
Nr = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
End With
.Range(.Cells(c.Row, "A"), .Cells(c.Row, "Y")).Copy
Ns.Range("A" & Nr).PasteSpecial xlPasteValues
End If
Next c
End With
Application.CutCopyMode = False
End Sub
you could try this:
Sub IdentifyInfraction()
Dim cell As Range
With Worksheets("raw_data") 'reference "raw data" sheet
For Each cell In .Range("C2", .cells(.Rows.Count, "C").End(xlUp)) ' loop through referenced sheet column C cells from row 2 down to last not empty one
Worksheets("Value_" & cell.Value).Range(cell.Address).Resize(, 25).Value = cell.Resize(, 25).Value 'have proper target sheet A:Y current cell row values as "raw data" sheet ones
Next
End With
End Sub

Excel VBA on combining multiple formulas [duplicate]

Hello everyone,
I have a problem to create VBA excel to duplicate data.
How to combine duplicate rows and sum the values 3 column in excel?
Thank you.
this one uses Remove Duplicates:
Sub dupremove()
Dim ws As Worksheet
Dim lastrow As Long
Set ws = Sheets("Sheet1") ' Change to your sheet
With ws
lastrow = .Range("A" & .Rows.Count).End(xlUp).Row
With .Range("B2:C" & lastrow)
.Offset(, 4).FormulaR1C1 = "=SUMIF(C1,RC1,C[-4])"
.Offset(, 4).Value = .Offset(, 4).Value
End With
With .Range("A1:A" & lastrow)
.Offset(, 4).Value.Value = .Value
End with
.Range("E1:G" & lastrow).RemoveDuplicates 1, xlYes
End With
End Sub
edited after OP's clarifications
try this
solution maintaining original data:
Option Explicit
Sub main()
With Worksheets("Sheet01") '<== change "Sheet01" as per your actual sheet name
With .Range("A1:C1").Resize(.Cells(.rows.Count, 1).End(xlUp).Row)
.Copy
With .Offset(, .Columns.Count + 1)
.PasteSpecial xlPasteAll ' copy value and formats
.Columns(2).Offset(1).Resize(.rows.Count - 1, 2).FormulaR1C1 = "=SUMIF(C1,RC1,C[-" & .Columns.Count + 1 & "])"
.Value = .Value
.RemoveDuplicates 1, xlYes
End With
End With
End With
End Sub
solution overwriting original data (kept for reference):
Sub main()
Dim helperRng As Range, dataRng As Range
Dim colToFilter As String
Dim colsToSumUp As Long
With Worksheets("Sheet01") '<== change "Sheet01" as per your actual sheet name
Set dataRng = .Range("A2:C2").Resize(.Cells(.rows.Count, 1).End(xlUp).Row - 1)
colToFilter = "A" ' set here the column header you want to sum up on
colsToSumUp = 3 ' number of adjacent columns to sum up with
Set helperRng = dataRng.Offset(, .UsedRange.Columns.Count + 1).Resize(, 1) 'localize "helper" cells first column out of sheet used range
With helperRng
.FormulaR1C1 = "=RC" & Cells(1, colToFilter).Column 'make a copy of the values you want to sum up on
.Offset(, 1).FormulaR1C1 = "=if(countif(R1C[-1]:RC[-1], RC[-1])=1,1,"""")" 'localize with "1" first occurrence of each unique value
With .Offset(, 2).Resize(, colsToSumUp)
.FormulaR1C1 = "=sumif(C" & helperRng.Column & ", RC" & helperRng.Column & ",C[" & Cells(1, colToFilter).Column - helperRng.Column - 1 & "])" 'sum up in adjacent columns
.Value = .Value 'get rid of formulas
End With
.Offset(, 1).SpecialCells(xlCellTypeFormulas, xlTextValues).EntireRow.Delete 'delete rows with repeted values you want to sum up on
dataRng.Columns(2).Resize(.rows.Count, colsToSumUp).Value = .Offset(, 2).Resize(.rows.Count, colsToSumUp).Value 'copy summed up values from "helper" cells
helperRng.Resize(, 1 + 1 + colsToSumUp).Clear 'clear "helper" cells
End With
End With
End Sub
it's commented so that you can follow the code and adapt to your actual data "structure"

VBA - copy the range in some cells and appear them into other sheet

I want a code that doing the following:
if the last 5 characters of the text value in the cell in column E is “(UK)” then the macro copies the range consisting of 4 cells in columns B,C,D,E in the same row and pastes below the last non-empty row in the worksheet “Sheet 1” in the same columns (so all ranges B-E with “(UK)” must be transferred to the sheet “Sheet1”);
I am just posting my code. Hope #Jonathan will learn it.
Sub CopyC()
Dim wb As Workbook
Dim ws As Worksheet
Dim sheet1lastrow As Long
Dim lastrow As Long
Set wb = ThisWorkbook
Set ws = wb.Worksheets("sheet1")
lastrow = ActiveSheet.Range("E" & Rows.Count).End(xlUp).Row
sheet1lastrow = ws.Range("E" & Rows.Count).End(xlUp).Row
For i = 1 To lastrow
If Right(ActiveSheet.Cells(i, 5).Value, 5) = "(UK)" Then
ActiveSheet.Range(Cells(i, 2), Cells(i, 5)).Copy
ws.Cells(sheet1lastrow + 1, 2).PasteSpecial xlValues
Application.CutCopyMode = False
Application.CutCopyMode = True
End If
Next
End Sub

How to only copy values using VBA

I need to copy values only without Formula from sheet to another. The following code does copy but only with Formula. I tried some solutions presented in this site but they give me errors.
For i = 2 To LastRow
'sheet to copy from
With Worksheets("Hoist")
'check column H value before copying
If .Cells(i, 8).Value >= -90 _
And CStr(.Cells(i, 9).Value) <> "Approved" _
And CStr(.Cells(i, 9).Value) <> "" _
And CStr(.Cells(i, 10).Value) = "" Then
'copy row to "display" sheet
.Rows(i).Copy Destination:=Worksheets("display").Range("A" & j)
j = j + 1
End If
End With
Next i
Try changing this line:
.Rows(i).Copy Destination:=Worksheets("display").Range("A" & j)
to this:
.Rows(i).Copy
Worksheets("display").Range("A" & j).PasteSpecial xlPasteValues
This however drops all formatting. To include formatting, you'll need to add another line like:
Worksheets("display").Range("A" & j).PasteSpecial xlPasteFormats
Another option is to enter a working column and use AutoFilter to avoid loops
insert a column in column A
the working column formuka is =AND(I2>-90,AND(J2<>"",J2<>"Approved"),K2="")
filter and copy the TRUE rows
delete working column A
code
Sub Recut()
Dim ws As Worksheet
Dim rng1 As Range
Set ws = Sheets("Hoist")
ws.AutoFilterMode = False
Set rng1 = Range([h2], Cells(Rows.Count, "H").End(xlUp))
ws.Columns(1).Columns.Insert
rng1.Offset(0, -8).FormulaR1C1 = "=AND(RC[8]>-90,AND(RC[9]<>"""",RC[9]<>""Approved""),RC[10]="""")"
With rng1.Offset(-1, -8).Resize(rng1.Rows.Count + 1, 1).EntireRow
.AutoFilter Field:=1, Criteria1:="TRUE"
.Copy Sheets("display").Range("A1")
Sheets("display").Columns("A").Delete
End With
ws.Columns(1).Delete
ws.AutoFilterMode = False
End Sub

How to use column headers to select different ranges of cells to populate data from a filename

This is a separate question stemming from this post: How to use the filename of an excel file to change a column of cells?
I noticed that in the last post's code it was referencing specific cells (J2,K2). However when using the code, I came into an error when the columns changed. So now I am seeking a way to modify the below code to use the names of the header columns to populate the 2nd column instead of referencing specific cells. I think the only line that really needs adjusting is the myRng line, but I will provide all the code I am trying for reference.
In case you don't read the other post, I will describe the issue. I am trying to fill in the 2nd column (name+type) based on the "name" column and the filename. When I was referencing the K or J row in the code, everything was working fine, but when I load a different file and the columns positions have changed, everything gets messed up.
I need to populate the 2nd column (name+type) to be the exactly the same number or rows as the 1st column (name) which is why I am using the Range ("K2:K" & lastCell) formula.
Is there a way to do this?
Current Attempted VBA code:
' Insert Column after name and then rename it name+type
Rows(1).Find("name").Offset(0, 1).EntireColumn.Insert
Rows(1).Find("name").Offset(0, 1).FormulaR1C1 = "name+type"
Dim myRng As Range
Dim lastCell As Long
Dim myOtherRange As Range
Dim column2Range As Range
myOtherRange = Rows(1).Find("name")
column2Range = Rows(1).Find("name+type")
lastCell = Range(myOtherRange).End(xlDown).Row
Set myRng = Range("K2:K" & lastCell)
myOtherRange.FormulaR2C1 = "=LEFT(MID(CELL(""filename""),SEARCH(""["",CELL(""filename""))+1, SEARCH(""]"",CELL(""filename""))-SEARCH(""["",CELL(""filename""))-1),5)&RC[-1]"
myOtherRange.FormulaR2C1.Select
Selection.Copy
myRng.Select
ActiveSheet.Paste
First Draft VBA code:
' Insert Column after name and then rename it name+type
Rows(1).Find("name").Offset(0, 1).EntireColumn.Insert
Rows(1).Find("name").Offset(0, 1).FormulaR1C1 = "name+type"
'Add the contents to the name+type column
Range("K2").Select
ActiveCell.FormulaR1C1 = "=LEFT(MID(CELL(""filename"",RC[-1]),SEARCH(""["",CELL(""filename"",RC[-1]))+1,SEARCH(""]"",CELL(""filename"",RC[-1]))-SEARCH(""["",CELL(""filename"",RC[-1]))-1),5)&RC[-1]"
Range("K2").Select
Selection.Copy
Range("K2:K8294").Select
ActiveSheet.Paste
#Scott or Siddharth Rout probably =) – Jonny 11 hours ago
I would never recommend this :) SO is full of experts who can assist you. Why do you want to limit the help that you can get? ;)
Is this what you are trying?
Option Explicit
Sub Sample()
Dim ws As Worksheet
Dim lRow As Long, aCol As Long
Dim aCell As Range
Set ws = Sheets("Sheet1") '<~~ Change this to the relevant sheet name
With ws
Set aCell = .Rows(1).Find("Name")
'~~> Check if the column with "name" is found
If Not aCell Is Nothing Then
aCol = aCell.Column
.Columns(aCol + 1).EntireColumn.Insert
.Cells(1, aCol + 1).Value = "Name+Type"
.Activate
.Rows(1).Select
With ActiveWindow
.SplitColumn = 0
.SplitRow = 1
.FreezePanes = True
End With
'~~> Get lastrow of Col which has "name"
lRow = .Range(Split(.Cells(, aCol).Address, "$")(1) & .Rows.Count).End(xlUp).Row
ThisWorkbook.Save
'~~> Add the formula to all the cells in 1 go.
.Range(Split(.Cells(, aCol + 1).Address, "$")(1) & "2:" & _
Split(.Cells(, aCol + 1).Address, "$")(1) & lRow).Formula = _
"=LEFT(MID(CELL(""filename"",RC[-1]),SEARCH(""["",CELL(""filename"",RC[-1]))+1," & _
"SEARCH(""]"",CELL(""filename"",RC[-1]))-SEARCH(""["",CELL(""filename"",RC[-1]))-1),5)&RC[-1]"
.Columns("A:AK").Columns.AutoFit
Else
MsgBox "Name Column Not Found"
End If
End With
End Sub
After modifying the code provided by Siddharth, this is the final code that worked for me. The save feature needed to also remove a format and the Formula to search and add the filename to the cells did not work without this edit. I also had to change the sheet to the activeSheet, because it was constantly changing. Here is the code:
Sub Naming()
Dim LR As Long, i As Long, lngCol As Long
lngCol = Rows(1).Find("NAME", lookat:=xlWhole).Column 'assumes there will always be a column with "NAME" in row 1
Application.ScreenUpdating = False
LR = Cells(Rows.Count, lngCol).End(xlUp).Row
For i = LR To 1 Step -1
If Len(Cells(i, lngCol).Value) < 4 Then Rows(i).Delete
Next i
Application.ScreenUpdating = True
' Insert Column after NAME and then rename it NAME+TYPE
Dim ws As Worksheet
Dim lRow As Long, aCol As Long
Dim aCell As Range
Set ws = ActiveSheet 'Need to change to the Active sheet
With ws
Set aCell = .Rows(1).Find("NAME")
' Check if the column with "NAME" is found, it is assumed earlier
If Not aCell Is Nothing Then
aCol = aCell.Column
.Columns(aCol + 1).EntireColumn.Insert
.Cells(1, aCol + 1).Value = "NAME+TYPE"
.Activate
' Freeze the Top Row
Rows("1:1").Select
With ActiveWindow
.SplitColumn = 0
.SplitRow = 1
End With
ActiveWindow.FreezePanes = True
' Get lastrow of Col which has "NAME"
lRow = .Range(Split(.Cells(, aCol).Address, "$")(1) & .Rows.Count).End(xlUp).Row
'Save the file and format the filetype
Dim wkb As Workbook
Set wkb = ActiveWorkbook 'change to your workbook reference
wkb.SaveAs Replace(wkb.Name, "#csv.gz", ""), 52 'change "csv.gz" to ".xlsm" if need be
' Add the formula to all the cells in 1 go.
.Range(Split(.Cells(, aCol + 1).Address, "$")(1) & "2:" & _
Split(.Cells(, aCol + 1).Address, "$")(1) & lRow).Formula = _
"=LEFT(MID(CELL(""filename""),SEARCH(""["",CELL(""filename""))+1, SEARCH(""]"",CELL(""filename""))-SEARCH(""["",CELL(""filename""))-1),5)&RC[-1]"
.Columns("A:AK").Columns.AutoFit
Else
MsgBox "NAME Column Not Found"
End If
End With
' Change the Range of the cursor
Range("A1").Select
Application.CutCopyMode = False
End Sub