New to VBA and simply wanted to create a macro which copies the tables within a specified range and pastes in the next available empty rows. What happens is that every time I run it it pastes into the same range i.e. B12 and don't know how to amend...
Sub CopyRange2()
Range("A1:I9").Select
Selection.Copy
Range("B12").Select
ActiveSheet.Paste
Application.CutCopyMode = False
End Sub
Would like to know why you have specified cell B12 ??
The below code will work if you just want to paste the data in the next available empty rows.
Sub CopyRange2()
Dim lastrow As Long
lastrow = Range("A" & Rows.Count).End(xlUp).Row
Range("A1:I9").Select
Selection.Copy
Range("A" & lastrow + 1).Select
ActiveSheet.Paste
Application.CutCopyMode = False
End Sub
Related
I have a file that consists of 5 data related sheets and an additional master sheet. These master sheet has a functionality that retrieves the data from all sheets into master sheet based on the ID.
The flow of the code for now is:
Range().Select
Application.CutCopyMode = False
Selection.Copy
Sheets("mSheet").Select
ActiveSheet.Paste
It does what I want in a simple way that it only shows the necessary data. What I ideally want is to have link between this data and actual sheet, so that once I retrieve data in the master sheet and perform any edit - this edit is made in the actual corresponding sheet.
Any idea and suggestion is appreciated.
Original partial VBA code:
Sheets("dSheet1").Select
ActiveSheet.ListObjects("Table").Range.AutoFilter Field:=3, Criteria1:=id
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToRight)).Select
Application.CutCopyMode = False
Selection.Copy
Sheets("masterSheet").Select
ActiveSheet.Paste Destination:=Sheets("masterSheet").Range("A8")
The following will copy the contents of your selection, but instead of pasting the value will enter the reference to the cell, so when the cell gets updated, so would the master sheet:
Sub foo()
Range("A1").Select
Sheets("mSheet").Range("A2").Formula = "=" & Selection.Address
End Sub
EDIT
The following will do the opposite of the code above, so it will copy the data, paste it in your master Sheet and then go back to the original copied range and enter the cell reference there so when the master is updated, so is that range:
Sub foo()
Range("A1").Select 'select the range to be copied
Application.CutCopyMode = False
Selection.Copy 'copy it
Sheets("mSheet").Range("A2").PasteSpecial (xlPasteValues) 'paste the value into your master sheet
Range("A1").Formula = "=" & Sheets("mSheet").Range("A2").Address
'go back to your previous selection and enter the formula to reference the specific cell
End Sub
UPDATE
Replace your code with the following, as it does the same but with fewer lines of code an without any Select statement:
Sub foo2()
Sheets("dSheet1").ListObjects("Table").Range.AutoFilter Field:=3, Criteria1:=ID
Sheets("dSheet1").Range("A2:D2").Copy Destination:=Sheets("masterSheet").Range("A8")
'change the range above to copy as many columns as you need
End Sub
Then add the following code behind you Master Sheet to detect changes:
Private Sub Worksheet_Change(ByVal Target As Range)
'place this code behing the masterSheet
LastRow = Sheets("dSheet1").Cells(Sheets("dSheet1").Rows.Count, "A").End(xlUp).Row
'get the last row of dSheet1
If Target.Address = "$A$8" Then 'if A8 changes
For i = 1 To LastRow 'loop through dSheet1 to find the ID
If Sheets("dSheet1").Cells(i, 3) = Range("C8").Value Then 'when ID found
Sheets("dSheet1").Cells(i, 1) = Range("A8").Value 'change relevant cell with new data
End If
Next i
End If
'below do the same as above to change data for other columns, add more to adapt it to be able to make changes to however many columns you are copying over
If Target.Address = "$B$8" Then
For i = 1 To LastRow
If Sheets("dSheet1").Cells(i, 3) = Range("C8").Value Then
Sheets("dSheet1").Cells(i, 2) = Range("B8").Value
End If
Next i
End If
If Target.Address = "$D$8" Then
For i = 1 To LastRow
If Sheets("dSheet1").Cells(i, 3) = Range("C8").Value Then
Sheets("dSheet1").Cells(i, 4) = Range("D8").Value
End If
Next i
End If
End Sub
This assumes that your ID's are unique and you are getting a single row as a result of your autofilter.
How about adding buttons.
CopyID - Copy range from SheetID = B1
After Editing, EditID - will clear range in SheetID = B1, and rewrites everything from mSheet Range from A3 then paste in SheetID = B1
Edit ID code:
Public Sub EditID(ID As String)
Sheets(ID).Select
If Range("A1").Value <> "" Then
Range("A1").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Clear
End If
Sheets("mSheet").Select
If Range("A3").Value <> "" Then
Range("A3").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Sheets(ID).Select
Range("A1").Select
ActiveSheet.Paste
End If
Sheets("msheet").Select
End Sub
I'm VERY new to the world of VBA. My goal is to create a macro that will Filter out text "FL" and "CA" in column H, delete the row that contains them from the original raw data, and copy them to new individual workbooks. I was able to do this with one state, but when I go to add another I run into issues. Here is the code I have for Moving FL to another workbook:
Sub PMAPMoveFL()
'Rename sheet 1
ActiveSheet.Name = "Sheet1"
'Add new sheet and return to sheet 1
Sheets.Add After:=ActiveSheet
Sheets("Sheet1").Select
'Filter out FL, copy and paste to sheet 2
Selection.AutoFilter
ActiveSheet.Range("A1:A5000").AutoFilter Field:=8, Criteria1:="FL", Operator:=xlAnd
ActiveSheet.UsedRange.Select
Selection.SpecialCells(xlCellTypeVisible).Select
Selection.Copy
Sheets("Sheet2").Select
Range("A1").Select
ActiveSheet.Paste
Rows("1:1").Select
Selection.Delete Shift:=xlUp
'Delete FL from sheet 1
Sheets("Sheet1").Select
Application.CutCopyMode = False
Selection.Delete
'Move FL sheet to new workbook
Sheets("Sheet2").Select
Sheets("Sheet2").Move
If Range("A1") = "" Then
MsgBox "This customer did not submit Florida data,you may delete this empty workbook"
End If
End Sub
It was tricky for me because the number of rows will never be absolute, but the column where the State is located is(Column H).
THANK YOU IN ADVANCE !!!
I'll try to clean up the code a little bit, and we'll work on giving you a dynamic range, as opposed to a fixed range in the process.
Dim LR as Long 'LR is Last Row
ActiveSheet.Name = "Sheet1"
With Sheets("Sheet1")
.Sheets.Add(After:=.Sheets(.Sheets.Count)).Name = "Sheet2"
LR = .Cells(.Rows.Count,1).End(xlUp).Row
.Rows(1).AutoFilter
.Range("A1:A5000").AutoFilter Field:=8, Criteria1:="FL", Operator:=xlAnd
.Range("A1:K" & LR).SpecialCells(xlCellTypeVisible).Copy Sheets("Sheet2").Range("A1")
End With
With Sheets("Sheet2")
.Rows(1).Delete
.Move
If .Range("A1") = "" Then
MsgBox "This customer did not submit Florida data,you may delete this empty workbook"
End If
End With
I got rid of a few redundancies with this post. I also took out the deletion of Sheet1 data; I was unsure if you wanted the whole sheet removed or just the visible cells that show Florida results. Note that I arbitrarily used the last column as K, since it incorporates H within the A:K range.
I would guess that you want to store FL results somewhere else (another workbook) and keep the existing data, but I don't want to be wrong.
I would recommend the following code, in lieu of the above changes, which will copy Sheet1 to Sheet2, then perform separate actions on either, where Sheet1 deletes Florida Options and Sheet2 deletes non-Florida Options:
Dim i, k, LR as Integer
ActiveSheet.Name = "Sheet1"
With Sheets("Sheet1")
.Sheets.Add(After:=.Sheets(.Sheets.Count)).Name = "Sheet2"
LR = .Cells(.Rows.Count,1).End(xlUp).Row
.Range("A1:K: & LR).Copy Sheets("Sheet2").Range("A1")
For i = 2 to LR
If .Cells(i,"H").Value="FL" Then
.Rows(i).Delete
End If
Next i
End With
With Sheets("Sheet2")
For k = 2 to LR
If .Cells(k,"H").Value="FL" Then
Else
.Rows(k).Delete
End If
Next k
End With
LR stays the same between the two sheets since the data is the same.
I have been trying to write a simple code that copies the value from one cell and paste its formula into all the cells in one column (There are several cells, around 3000). The code works, but it takes around 30 min to run, so it's not ok for me. I also tried to let the value of the formula without "=" and then use the replace command, but it does not work as well. Anyone could help me with that in order to run the macro in 1 min? This is the part of my code that I try to do that:
sub copy_paste
Worksheets("Formatar").Range("H1:L1").Copy
Worksheets("Formatar").Range("H3").PasteSpecial xlValue
Worksheets("Formatar").Range("H3:L3").Copy
Range(Selection, Selection.End(xlDown)).Select
Selection.PasteSpecial xlFormulas
end sub
Tell me if this help you...
Sub copy_paste()
Worksheets("Formatar").Range("H1:L1").Copy 'Copy from row 1
Worksheets("Formatar").Range("H3").PasteSpecial xlPasteValues 'paste the values to row 3
Worksheets("Formatar").Range("H3:L3").Copy 'here you copy that (the values)
Range(Selection, Selection.End(xlDown)).Select 'you select eveything from row3
Selection.PasteSpecial xlPasteValues 'and paste it... but you copy just values from 3!
End Sub
And then you paste it over the first occurrence and you lost data.
Here is my suggest.
Sub copy_paste()
Dim sht As Worksheet
Dim r
Dim H
Dim L
Set sht = Sheets("Formatar") 'store the sheet
sht.Activate 'activate it!
Range("H1:L1").Copy
Range("H3").PasteSpecial xlPasteFormulas 'Paste the formula
Range("H3:L3").Copy 'then copy again
H = Range("H1").Column 'Just to take the number of the columns H and L
L = Range("L1").Column
r = Range("H3").End(xlDown).Row - 1 'Take the number of the last blank row.
Range(Cells(3, H), Cells(r, L)).PasteSpecial xlPasteValues
'Here you paste values, of if you need the
'formula use this: xlPasteFormulas
Application.CutCopyMode = False 'never forget this...
End Sub
Edit
May be this could help...
'Application.Calculation = xlManual
Sub copy_paste()
Dim sht As Worksheet
Dim r
Dim H
Dim L
Set sht = Sheets("Formatar") 'store the sheet
sht.Activate 'activate it!
Range("H1:L1").Copy
Range("H3").PasteSpecial xlPasteFormulas 'Paste the formula
Application.Calculation = xlManual 'Not automatic calculation
Range("H3:L3").Copy 'then copy again
H = Range("H1").Column 'Just to take the number of the columns H and L
L = Range("L1").Column
r = Range("H3").End(xlDown).Row - 1 'Take the number of the last blank row.
Range(Cells(3, H), Cells(r, L)).PasteSpecial xlPasteValues
'Here you paste values, of if you need the
'formula use this: xlPasteFormulas
Application.CutCopyMode = False 'never forget this...
Calculate 'Calculate the whole sheet
Application.Calculation = xlCalculationAutomatic 'return automatic calculation
End Sub
I would like to loop through column A in Worksheet1 and find the first cell which has a specified text "Oil Production". This cell is the first cell in the array I wish to copy to Worksheet2. This cell and the size of the array will change from time to time, hence the code I have used. I then paste it into cell B7 in Worksheet2 which will never change.
This is my formula. I get the error at line ActiveSheet.Paste
Sub Test()
Application.ScreenUpdating = False
For Each Cell In Sheets("Sheet1").Range("A:A")
If Cell.Value = "Oil Production" Then
ActiveSheet.Cells.Select
Range(ActiveCell, Cells(ActiveCell.End(xlDown).Row, ActiveCell.End(xlToRight).Column)).Select
Selection.Copy
Sheets("Sheet2").Select
Range("B7").Select
ActiveSheet.Paste
End If
Next
End Sub
resize the area:
Sub Test()
Dim MyRowCount As Long, MyColCount As Long
Application.ScreenUpdating = False
For Each Cell In Sheets("Sheet1").Range("A1:A" & Range("A" & Rows.count).end(xlup).row) 'This make it poll the used data rather than the whole column
If Cell.Value = "Oil Production" Then
ActiveSheet.Cells.Select
With Range(ActiveCell, Cells(ActiveCell.End(xlDown).Row, ActiveCell.End(xlToRight).column))
.Copy
MyRowCount = .Rows.Count
MyColCount = .Columns.Count
End With
Sheets("Sheet2").Select
Range("B7").Resize(MyRowCount, MyColCount).PasteSpecial xlPasteAll
'Do you need to flick back to Sheet1 after pasting?
End If
Next
End Sub
Also I took out a bunch of selects for you.
Range("A1").Select
Selection.Paste
can be written as
Range("A1").PasteSpecial XLPasteAll
You can chop out most selects this way, you can see I have also done it with the Range you are copying
I have the following VBA code that takes a single row from Sheet "Tabled data", copies the data, then pastes the data into the next available row in Sheet "Running list". However the original row has formulas and I need the values to paste, not the formulas. I've seen numerous ways to do it with Range.PasteSpecial but this code didn't use Range and I'm not sure how to incorporate it.
Note: I modified this code from here: http://msdn.microsoft.com/en-us/library/office/ff837760(v=office.15).aspx. It originally had an IF statement to match content in a cell then paste it in a certain sheet according to the content in the cell. I only had one sheet to copy to and didn't need the IF. I don't really need to find the last row of data to copy either as it will only ever be one row with range of A2:N2. But if I take out the FinalRow section and the For and replace with Range("A2:N2") it doesn't work so I left those in.
Any guidance on how to add in the PasteValues property without making this more complicated? I'm also open to simplification of the For or FinalRow variable such as using Range. I'm only sort of familiar with VBA, having done a few things with it, but usually after much searching and modifying code.
Public Sub CopyData()
Sheets("Tabled data").Select
' Find the last row of data
FinalRow = Cells(Rows.Count, 1).End(xlUp).Row
' Loop through each row
For x = 2 To FinalRow
ThisValue = Cells(x, 1).Value
Cells(x, 1).Resize(1, 14).Copy
Sheets("Running list").Select
NextRow = Cells(Rows.Count, 1).End(xlUp).Row + 1
Cells(NextRow, 1).Select
ActiveSheet.Paste
Sheets("Tabled data").Select
Next x
End Sub
Hopefully we can actually make this more simple.
Public Sub CopyRows()
Sheets("Sheet1").UsedRange.Copy
lastrow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
'check if the last cell found is empty
If IsEmpty(ActiveSheet.Cells(lastrow, 1)) = True Then
'if it is empty, then we should fill it
nextrow = lastrow
Else
'if it is not empty, then we should not overwrite it
nextrow = lastrow + 1
End If
ActiveSheet.Cells(nextrow, 1).Select
ActiveSheet.Paste
End Sub
edit: I expanded it a little so that there won't be a blank line at the top
I found a working solution. I recorded a macro to get the paste special in there and added the extra code to find the next empty row:
Sub Save_Results()
' Save_Results Macro
Sheets("Summary").Select 'renamed sheets for clarification, this was 'Tabled data'
'copy the row
Range("Table1[Dataset Name]").Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Copy
' paste values into the next empty row
Sheets("Assessment Results").Select
Range("A2").Select
NextRow = Cells(Rows.Count, 1).End(xlUp).Row + 1
Cells(NextRow, 1).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
' Return to main sheet
Sheets("Data Assessment Tool").Select
End Sub
Just copy the data all at once, no need to do it a row at a time.
Sub CopyData()
With ThisWorkbook.Sheets("Tabled data")
Dim sourceRange As Range
Set sourceRange = .Range(.Cells(2, 1), .Cells(getLastRow(.Range("A1").Parent), 14))
End With
With ThisWorkbook.Sheets("Running list")
Dim pasteRow As Long
Dim pasteRange As Range
pasteRow = getLastRow(.Range("A1").Parent) + 1
Set pasteRange = .Range(.Cells(pasteRow, 1), .Cells(pasteRow + sourceRange.Rows.Count, 14))
End With
pasteRange.Value = sourceRange.Value
End Sub
Function getLastRow(ws As Worksheet, Optional colNum As Long = 1) As Long
getLastRow = ws.Cells(ws.Rows.Count, colNum).End(xlUp).Row
End Function
Private Sub Load_Click()
Call ImportInfo
End Sub
Sub ImportInfo()
Dim FileName As String
Dim WS1 As Worksheet
Dim WS2 As Worksheet
Dim ActiveListWB As Workbook
Dim check As Integer
'Application.ScreenUpdating = False
Set WS2 = ActiveWorkbook.Sheets("KE_RAW")
confirm = MsgBox("Select (.xlsx) Excel file for Data transfer." & vbNewLine & "Please ensure the sheets are named Sort List, Second and Third.", vbOKCancel)
If confirm = 1 Then
FileName = Application.GetOpenFilename(FileFilter:="Excel Files (*.xls*),*.xls*", _
Title:="Select Active List to Import", MultiSelect:=False)
If FileName = "False" Then
MsgBox "Import procedure was canceled"
Exit Sub
Else
Call CleanRaw
Set ActiveListWB = Workbooks.Open(FileName)
End If
Set WS1 = ActiveListWB.Sheets("Sort List")
WS1.UsedRange.Copy 'WS2.Range("A1")
' WS2.Range("A1").Select
WS2.UsedRange.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
'WS2.Range ("A1")
ActiveWorkbook.Close False
'Call ClearFormulas
' Call RefreshAllPivotTables
Sheets("Key Entry Data").Select
'Sheets("Raw").Visible = False
'Application.ScreenUpdating = True
MsgBox "Data has been imported to workbook"
Else
MsgBox "Import procedure was canceled"
End If
Application.ScreenUpdating = True
End Sub
Sub CleanRaw()
Sheets("KE_RAW").Visible = True
Sheets("KE_RAW").Activate
ActiveSheet.Cells.Select
Selection.ClearContents
End Sub