I am trying to create a simple insert row to 'table', 'copy' second row and 'paste' into first row. Currently I have just created the below as it was logical to me and I cannot find any reference on the internet so far.The table has another table above it so the cell are constantly shuffling down and have no point of reference aside from the table itself.
It inserts a row but does not copy and paste the values, Formulas, and formatting (data validated droplist) from second row. I also want to clear the contents of the first and fifth column in the first row. there are no error messages.
Sub AddPkgBeer()
'
' AddPkgBeer Macro
'
'
Sheets("BEER MENU").Select
ActiveSheet.Unprotect Password:="password"
Range("Table36356").Select
Selection.ListObject.ListRows.Add (1)
ActiveSheet.ListObjects("Table36356").DataBodyRange(2).Select
Selection.Copy
ActiveSheet.ListObjects("Table36356").DataBodyRange(1).Select
Selection.PasteSpecial Paste:=xlPasteFormulasAndNumberFormats, Operation:= _
xlNone, SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
ActiveSheet.ListObjects("Table36356").DataBodyRange(1, 1).Select
Sheets("BEER MENU").Select
ActiveSheet.Protect Password:="password"
End Sub
Sub AddPkgBeer()
Dim ws As Worksheet, rng As Range, tbl As ListObject
Set ws = ActiveSheet
Set tbl = ws.Range("Table36356").ListObject
tbl.ListRows.Add 1
Set rng = tbl.ListRows(1).Range
tbl.ListRows(2).Range.Copy rng
rng.Cells(1, 1) = ""
rng.Cells(1, 5) = ""
End Sub
Related
I currently have code that inserts two columns, and copies values from two other columns into these two new columns.
'Insert 2 Column to the Left of S
Columns("S:T").Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeft
'Copy Column J into Column S
Columns("J:J").Select
Selection.Copy
Columns("S:S").Select
Selection.PasteSpecial Paste:=xlPasteValues
Selection.PasteSpecial Paste:=xlFormats
'Copy Column Q into Column T
Columns("Q:Q").Select
Selection.Copy
Columns("T:T").Select
Selection.PasteSpecial Paste:=xlPasteValues
Selection.PasteSpecial Paste:=xlFormats
However, I want to change it so that the value in Column J is only copied IF the value next to it in Column I is not "DoNotCopy" (or another specific text).
I know, as a workaround, I could insert another column and have an IF statement to only show the value if blah blah... and copy that column value over instead. But this is not as "pretty" as VBA doing the work. Or would you disagree, and this is the better way to do it?
Insert Column and Copy Conditionally to It
Sub InsertData()
Dim ws As Worksheet: Set ws = ActiveSheet ' improve!
Dim rg As Range: Set rg = ws.UsedRange
With Intersect(rg.EntireRow, ws.Columns("S:T"))
.Insert Shift:=xlShiftToRight, CopyOrigin:=xlFormatFromLeftOrAbove
' Formats
Intersect(rg, ws.Columns("J")).Copy
.Columns(1).Offset(, -2).PasteSpecial xlPasteFormats
' Values
.Columns(1).Offset(, -2).Value = ws.Evaluate("IF(" _
& Intersect(rg, ws.Columns("I")).Address & "<>""DoNotCopy""," _
& Intersect(rg, ws.Columns("J")).Address & ","""")")
' Formats
Intersect(rg, ws.Columns("Q")).Copy
.Columns(2).Offset(, -2).PasteSpecial xlPasteFormats
' Values
.Columns(2).Offset(, -2).Value = Intersect(rg, ws.Columns("Q")).Value
Application.CutCopyMode = False
End With
End Sub
Place the IF function into your target column. This logic assumes the first row is the beginning of the data, adjust as needed.
Dim r As Range, idx As Long
'identify the last cell with a value
idx = Cells(Rows.Count, "S").End(xlUp).Row
'set the range to the target column
Set r = Range("J1:J" & idx)
'value the target column with the IF function
Cells(1, "J").Formula = "=IF(T1=""DoNotCopy"","""",S1)"
r.FillDown
r.copy
r.PasteSpecial xlPasteValues
The code below is working as designed, with one exception:
Range b4:b100 are lookup formulas from another sheet where everything below B34 is a #value! error where I'm specifying =iferror(formula),""
It is copying the resulting "" and so the next time I it runs, it begins to paste on the target sheet on B101 rather than B35.
How can I specify "Do not use any space on the target sheet with blanks where formulas existed on the source sheet"?
Sub COPYTOSAVEDWORK()
Sheets("FORMULAWORKED").Range("B4:Q100").Select
Selection.Copy
Sheets("WORKED_CLAIMS").Cells(Rows.Count, "A").End(xlUp).Offset(1). _
PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:=xlNone, _
SkipBlanks:=True, Transpose:=False
Exit Sub
End Sub
You can call .Value = .Value on the pasted range, and that will eliminate cells with the empty string:
Sub Test()
Dim formulaRng As Range
Set formulaRng = ThisWorkbook.Sheets("FORMULAWORKED").Range("B4:Q100")
With ThisWorkbook.Sheets("WORKED_CLAIMS")
Dim nextRow As Long
nextRow = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
formulaRng.Copy
.Cells(nextRow, "A").PasteSpecial Paste:=xlPasteValuesAndNumberFormats
Application.CutCopyMode = False
With .Cells(nextRow, "A").Resize(formulaRng.Rows.Count, formulaRng.Columns.Count)
.Value = .Value
End With
End With
End Sub
A value transfer as per #BigBen would work great, but you seem to want to copy/paste numbers and NumberFormat. Maybe something like the below would work:
Sub Test()
Dim rng As Range
Dim arr As Variant
With Sheets("FORMULAWORKED")
.Range(Join(Filter(.[TRANSPOSE(IF(B4:B100<>"","B"&ROW(B4:B100)&":Q"&ROW(B4:B100),"|"))], "|", False), ",")).Copy
Sheets("WORKED_CLAIMS").Cells(Rows.Count, "A").End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
End With
End Sub
I want to copy data in certain cells to another sheet in a table.
My code copies the data and searches for the cell to be pasted to. If there is a value in the destination cell, it is looped to check the subsequent rows in the same column until it finds an empty cell.
If there's 2000 rows of data currently in the table, it will search all 2000 cells before landing in the 2001st row.
The amount of time taken to execute the code is affected by the size of the table.
Is there any way to execute faster?
Below is a sample, its copying data from two cells.
Sub Test()
Sheets("Sheet1").Select
Range("K10").Select
Selection.Copy
Sheets("Table").Select
Range("A2").Select
Do While Not (ActiveCell.Value = "")
ActiveCell.Offset(1, 0).Activate
Loop
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
Sheets("Sheet1").Select
Range("G15").Select
Selection.Copy
Sheets("Table").Select
Range("B2").Select
Do While Not (ActiveCell.Value = "")
ActiveCell.Offset(1, 0).Activate
Loop
End sub
Try following sub.
Sub CopyPaste()
Dim sht1, sht2 As Worksheet
Set sht1 = Worksheets("Sheet1")
Set sht2 = Worksheets("Table")
sht1.Range("K10").Copy sht2.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
sht1.Range("G15").Copy sht2.Cells(Rows.Count, 2).End(xlUp).Offset(1, 0)
End Sub
It's unclear on whether you expect to find interim blank cells within the worksheet's used range or whether you expect to always put the new values at the bottom of the used range. This should work for both scenarios.
Sub Test()
Dim ws1 As Worksheet
Set ws1 = Worksheets("sheet1")
With Worksheets("table")
'force a definition for a .UsedRange on the worksheet
.Cells(.Rows.Count, "A") = Chr(32)
.Columns(1).SpecialCells(xlCellTypeBlanks).Cells(1) = ws1.Cells(10, "K").Value
.Columns(1).SpecialCells(xlCellTypeBlanks).Cells(1) = ws1.Cells(15, "G").Value
'clear the artificial .UsedRange
.Cells(.Rows.Count, "A").Clear
'Debug.Print .UsedRange.Address(0, 0)
End With
End Sub
I'm new to VBA. I use a one column array for the variable data. Starting at the first cell (A1) I want to copy the text value in A1, paste to Sheet2,in A5, go back to the array and do it all over again, until I get to an empty cell. Easy right?
Here is the code that I have, I can not copy the value and paste it.
Thank you, for your suggestions!!!
Sub copylist()
' copylist Macro
Worksheets("ID nbr").Select
Range("B3").Select
For Each c In Worksheets("ID nbr").Range("B3:B20").Cells
If c.Value <> "" Then
Sheets("ID nbr").Select
Dim rgCopy As Range
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
Range("B4:G4").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Findings").Select
Range("B4").Select
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
End If
Next
End Sub
You have made a great attempt using the macro recorder. Now let's clean it up:
I moved all the sheets into variables to limit the amount of typing.
I removed all the .Select and .Activate, these just slow the code down and if referenced properly they are not needed.
When only values are wanted, then assigning them directly is quicker than using the clipboard. We can do this as one block of cells.
I used a counter to move down one row on the target sheet for every row found in the original sheet.
The code:
Sub copylist()
Dim ows As Worksheet
Dim tws As Worksheet
Dim c As Range
Dim i As Long
Set ows = Sheets("ID nbr") 'Original sheet
Set tws = Sheets("Findings") 'Target sheet
i = 4 'this is the first row in the target sheet
With ows
For Each c In .Range("B3:B20").Cells
If c.Value <> "" Then
tws.Range(tws.Cells(i, "B"), tws.Cells(i, "G")).Value = .Range(.Cells(c.Row, "B"), .Cells(c.Row, "G")).Value
i = i + 1
End If
Next c
End With
End Sub
I am new to the VBA and Macro world. I am trying to create a data collection sheet. First part data is collected in from 1 workbook and placed in workbook master. What I would like to achieve is the new data that I extract will be placed below the previous entry in the workbook master.
Sub Extract() ' ' Extract Macro ' ' Keyboard Shortcut: Ctrl+e '
Sheets("For Coordinator Use").Select
Range("A2:M41").Select
Selection.Copy
Windows("Nimble Schedule Import Template- ops.xlsx").Activate
Range("A1000").End(xlUp).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
ActiveSheet.ListObjects("Table1").Range.AutoFilter Field:=1, Criteria1:= _
"=0", Operator:=xlOr, Criteria2:="="
Application.CutCopyMode = False
Selection.EntireRow.Delete
ActiveSheet.ListObjects("Table1").Range.AutoFilter Field:=1
Windows("Coverage Request Form (9).xlsx").Activate
Sheets("Request Form").Select
End Sub
Here is a modified and commented copy of your code:
Sub Extract() ' ' Extract Macro ' ' Keyboard Shortcut: Ctrl+e '
Sheets("For Coordinator Use").Select
Range("A2:M41").Copy 'No need to select then copy, just copy is fine
Windows("Nimble Schedule Import Template- ops.xlsx").Activate
'I have offset the last row of data by 1 row below, use rows.count rather than a hard row number. Also no need to select
Range("A" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
ActiveSheet.ListObjects("Table1").Range.AutoFilter Field:=1, Criteria1:="=0", Operator:=xlOr, Criteria2:="="
'I don't know what row is selected here but it was in your code so I left it, also no need for cutcopymode as it will cancel when you delete anyway
Selection.EntireRow.Delete
ActiveSheet.ListObjects("Table1").Range.AutoFilter Field:=1
Windows("Coverage Request Form (9).xlsx").Activate
Sheets("Request Form").Select
End Sub
Please read the comments and ask any questions about it where you are unsure. These changes are because you have stipulated you are new to this and I don't want to confuse you, this is NOT the best way to do it, I would much rather set up something with arrays than a copy and paste. If you are comfortable with this concept post back and I will modify my code for you.
It depends how you would like to do it. Do you want to maybe use an array to store the data in then extract to the master spreadsheet or do you want to just use excels built in functions to copy and paste the data like you are doing above. You could also use a scripting dictionary to store the data as well there are many ways to do it just wondering which route you want to take. If you want to have a high performance macro then I suggest not to use excel's built in functions as they are slower than using arrays.
Update 2015-08-20
I have got the copy and paste using the range object. However I see you want to delete some other values from your list although they are kept in a table and not in a spreadsheet. Is this correct? Please have a look at the code I made some comments asking for some clarifications. Sorry for taking so long I was busy finishing something up at work.
Sub Extract() ' ' Extract Macro ' ' Keyboard Shortcut: Ctrl+e '
Dim wb As Workbook, ws As Worksheet, rng As Range
Set wb = ThisWorkbook 'Set up the Excel objects you want to use
Set ws = wb.Worksheets("For Coordinator Use")
Set rng = ws.Range("A2:M41") 'asuming this is not changing
'Sheets("For Coordinator Use").Select 'You do not need to select if you use the objects
'Range("A2:M41").Select 'You do not need to select if you use the objects
'Selection.Copy 'you can also get rid of this if using objects
Dim wbDest As Workbook, wsDest As Worksheet, rngDest As Range
Set wbDest = Application.Workbooks("Nimble Schedule Import Template- ops.xlsx") ' Assuming that it is opened
'Windows("Nimble Schedule Import Template- ops.xlsx").Activate 'dont need to activate anything
Set wsDest = wbDest.Worksheets("Sheet1")
Set rngDest = wsDest.Range("A1:A35000")
''optimize the application
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
''''
'''Find the first empty cell in destRng
'Range("A1000").End(xlUp).Select ' this will select the range that is blank only if it does not have data to begin with
Dim i As Long, j As Long, rngAdd As String 'i is the counter and j stores the row where it is blank
For i = 1 To rngDest.Cells.Count
If IsEmpty(rngDest.Cells(i, 1).Value) Then
j = i
i = rngDest.Cells.Count
End If
Next i
'reset the rngDest
Set rngDest = Nothing
rngAdd = "A" & j & ":M" & (j + 39)
Set rngDest = wsDest.Range(rngAdd)
'make rngDest = rng.Value since they have the same dimension this works
rngDest = rng.Value 'Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
' :=False, Transpose:=False
'I am not sure what you are trying to acheive here a filter??'ActiveSheet.ListObjects("Table1").Range.AutoFilter Field:=1, Criteria1:= _
' "=0", Operator:=xlOr, Criteria2:="="
'Application.CutCopyMode = False
'Selection.EntireRow.Delete
'ActiveSheet.ListObjects("Table1").Range.AutoFilter Field:=1
''Looks like you are deleting all with a value of "=0"
'Windows("Coverage Request Form (9).xlsx").Activate
'Sheets("Request Form").Select
'Release Objects
Set rngDest = Nothing
Set wsDest = Nothing
Set wbDest = Nothing
Set rng = Nothing
Set ws = Nothing
Set wb = Nothing
''set excel optimization as normal again
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAuto
Application.EnableEvents = True
End Sub