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
Related
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
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'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 trying to get data from every other sheet in the workbook and paste it into a master sheet (Sheet1), but when I run my code nothing happens, Can someone tell me why this is?
Dim wb As Workbook
Dim ws As Worksheet
Set wb = ActiveWorkbook
wb.Sheets("Sheet1").Cells(1, 1).Text = "Started"
i = 1
'cells is row,col
For Each objWorksheet In wb.Worksheets
'ws.Cells(1, i).Value = objWorksheet.Name
'objWorksheet.Activate
'ws = wb.ActiveSheet
doJStuff i, objWorksheet
i = i + 1
Next
wb.Sheets("Sheet1").Cells(1, 1).Text = "DONE"
End Sub
Sub doJStuff(row, ws)
ws.Select
Range("A2").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Sheet1").Select
ActiveSheet.Cells(row, 1).Select
ActiveSheet.Paste
'end paste name
'copy post history and transpose into row 2 on sheet1
ws.Select
Range("H2:H30").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Sheet1").Select
ActiveSheet.Cells(row, 2).Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
'end post history
End Sub
You've got a number of problems with your code. First of all, avoid using Select wherever possible. Second, you are not properly assigning variables. You should put Option Explicit on the top of the module and then make sure you've assigned things correctly.
As for the actualy code, when you are copying/pasting the H2:H30 range into your first sheet you are going to only end up getting the first value in the range for every sheet except the last because you are pasting 28 rows but only incrementing the destination row by one. I didn't fix that but it's worth pointing out. I also left in your comments though they don't make much sense. Without knowing what you are trying to do, I've only cleaned up some of your code but it probably still won't work exactly right.
Sub YourSub()
Dim wb As Workbook
Dim wksht As Worksheet
Dim i As Integer
Set wb = ActiveWorkbook
wb.Sheets("Sheet1").Cells(1, 1).Text = "Started"
i = 1
'cells is row,col
For Each wksht In Worksheets
'ws.Cells(1, i).Value = objWorksheet.Name
'objWorksheet.Activate
'ws = wb.ActiveSheet
doJStuff i, wksht
i = i + 1
Next
wb.Sheets("Sheet1").Cells(1, 1).Text = "DONE"
End Sub
Sub doJStuff(row As Integer, ws As Worksheet)
ws.Range("A2").Copy
Sheets("Sheet1").Cells(row, 1).PasteSpecial
'end paste name
'copy post history and transpose into row 2 on sheet1
ws.Range("H2:H30").Copy
Sheets("Sheet1").Cells(row, 2).PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
'end post history
End Sub
I am trying to use a macro to copy an entire column of data but stop once it hits a 0 or blank as I only want the cells in the column that actually have data in them.
Edit:
Worksheets("C_Plan").Select
Range("O13").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy Worksheets("Summary").Select
Range("A4").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
I forgot to mention i am pasting from 3 different worksheets and after i select the data in one worksheet, I need the second paste to start where the first paste left off. I have been using
Selection.End(xlDown).Select
ActiveCell.Offset(1, 0).Select
Try this and tell me if this works for you
Sub Test()
Dim R As Integer
Dim P As Integer
Dim ws2 As Worksheet
Dim ws As Worksheet
Set ws2 = Worksheets("Sheet2")
Set ws = Worksheets("Sheet1")
ws.Select
R = Range("O65536").End(xlUp).Row
ws.Range(Cells(1, 15), Cells(R, 15)).Select
Selection.Copy
ws2.Select
P = Range("A65536").End(xlUp).Row
ws2.Cells(P, 1).Offset(1, 0).Select
Selection.PasteSpecial
End Sub
This will select all the Cells in column O with a value and copy it and then paste it to the worksheet "summary" starting in the last cell in Column A with data.
Assuming you have the top-most cell of your column stored as startCell as Range I would do something like this:
dim endCell as Range
dim colRange as Range
set endCell = startCell ' Here's where you'll need startCell already!
While endCell <> "" And endCell <> "0"
set endCell = endCell.Offset(1) ' Move down the column
Loop
set colRange = Range(startCell, endCell)
' Now you can do with "colRange" as you please. Copy, paste etc.