Can someone help me modify this code so that it can reference the data in cell A6 and paste to the sheet named after that data.
I already have a working macro for pasting data from a cover sheet to individual worksheets, each day, and without overwriting previously populated cells (See below).
The issue is that the code is too specific and is not easily manipulated when new rows are introduced to the "Balancer" cover-sheet. Here is an example of the current code:
Sub pastetosheet()
r = 1
Sheets("Balancer").Range("B2").Copy
Sheets("X9X9USDFEDT6").Range("C35").End(xlUp).Offset(r, 0).PasteSpecial _
paste:=xlPasteValues
Application.CutCopyMode = False
Sheets("Balancer").Range("D2").Copy
Sheets("X9X9USDFEDT6").Range("D35").End(xlUp).Offset(r, 0).PasteSpecial _
paste:=xlPasteValues
Application.CutCopyMode = False
Sheets("Balancer").Range("F2").Copy
Sheets("X9X9USDFEDT6").Range("F35").End(xlUp).Offset(r, 0).PasteSpecial _
paste:=xlPasteValues
Application.CutCopyMode = False
Sheets("Balancer").Range("G2").Copy
Sheets("X9X9USDFEDT6").Range("H35").End(xlUp).Offset(r, 0).PasteSpecial _
paste:=xlPasteValues
Application.CutCopyMode = False
End Sub
I want the code to copy data in Range "B6" on the "Balancer" tab, then reference the data in the cell to the left (A6 in this case) to find out which sheet it will be pasting to. Then use the paste rules already in place from the current code.
If each row specifies its own destination sheet in column A, this should do:
Sub pasteToSheetOfA()
Dim r As Long, t As Range
With Sheets("Balancer")
For r = 1 To .Range("B1000000").End(xlUp).Row ' for all rows of column B
' get the target sheet specified in column A, goto beyond last cell in C of this sheet
Set t = Sheets(.Range("A" & r).value).Range("C1000000").End(xlUp).Offset(1)
' now copy the cells of the row according to the rules of the OP
t.value = .Cells(r, "B").value
t.Offset(,1).value = .Cells(r, "D").value
t.Offset(,3).value = .Cells(r, "F").value
t.Offset(,5).value = .Cells(r, "G").value
Next
End With
End Sub
Related
My goal is to copy and paste rows that meet a certain criteria into a table in another workbook.
My VBA works perfectly except for it pastes in the empty cell below the table. Not in the empty cells below the headers within the table.
PS. I know using select is generally frowned upon, but I needed to use fairly basic syntax so that if the next person needs to modify this and is unfamiliar with VBA they can.
Sub Export()
Sheets("Export Format").Select
Cells(13, "D").Calculate
With Range("A1", Cells(Rows.Count, "L").End(xlUp)) 'reference its column A:G cells from row 1 (header) down to last not empty one in column "A"
.AutoFilter Field:=6, Criteria1:="<>0" ' filter referenced cells on 6th column with everything but "0" content
If Application.WorksheetFunction.Subtotal(103, .Columns(1)) > 1 Then
.Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible).Copy ' copy filtered cells skipping headers
With Workbooks.Open(Filename:="Z:\Tracking\Database.xlsx").Sheets("Sheet1") 'open wanted workbook and reference its wanted sheet
.Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone _
, SkipBlanks:=False, Transpose:=False 'paste filtered cells in referenced sheet from ist column A first empty cell after last not empty one
.Parent.Close True 'Save and closes referenced workbook
End With
Application.CutCopyMode = False
End If
End With
On Error Resume Next
Sheets("Export Format").ShowAllData 'Clears Filters
On Error GoTo 0
Sheets("Export Format").Select 'Brings back to Main request sheet
End Sub
Try using a property of the table such as InsertRowRange
Sub Export()
Const DBFILE = "Z:\Tracking\Database.xlsx"
Dim wb As Workbook, wbDB As Workbook
Dim ws As Worksheet, tbl As ListObject
Dim rngFilter As Range, x, rng As Range
Set wb = ThisWorkbook
Set ws = wb.Sheets("Export Format")
x = Application.WorksheetFunction.Subtotal(103, ws.Columns(1))
If x <= 1 Then
ws.Select
Exit Sub
End If
' set filter range
With ws
.Range("D13").Calculate
' column A:L cells from row 1 (header)
' down to last not empty one in column "A"
Set rngFilter = .Range("A1", .Cells(Rows.Count, "L").End(xlUp))
End With
' open wanted workbook and reference its wanted sheet
Set wbDB = Workbooks.Open(DBFILE)
With wbDB.Sheets("Sheet1")
Set tbl = .ListObjects("Table1")
If tbl.InsertRowRange Is Nothing Then
Set rng = tbl.ListRows.Add.Range
Else
Set rng = tbl.InsertRowRange
End If
End With
' filter on 6th column with everything but "0" content
With rngFilter
.AutoFilter Field:=6, Criteria1:="<>0"
' copy filtered cells skipping headers
.Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible).Copy
'paste filtered cells in referenced sheet
'from ist column A first empty cell after last not empty one
rng.PasteSpecial Paste:=xlPasteValues, _
Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
End With
wbDB.Close True 'Save and closes referenced workbook
ws.AutoFilterMode = False
ws.Select 'Brings back to Main request sheet
MsgBox "Ended"
End Sub
I'm new with VBA and I am trying to create a macro for work to make everyone's life easier. My goal is to copy rows (or just copy the data in the first column when the second column is "0") from one worksheet named "Bulk Update" with the condition of column B having the value "0" to the last worksheet, at the bottom of the worksheet after the data. I don't know how to reference the last worksheet name. Here is the code that I made (please don't judge me as I am still new and googling around), which I know is completely wrong...
Public Sub CNPPrevOOS()
Worksheets("Bulk Update").Select
a = Worksheets("Bulk Update").Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To a
If Worksheets("Bulk Update").Cells(i, 2).Value = "0" Then
Selection.Copy
ThisWorkbook.Worksheets(ThisWorkbook.Sheets.Count).Range("A1").Value = 100
Range("A30000").Select
Selection.End(xlUp).Select
ActiveCell.Offset(1, 0).Select
ActiveSheet.Paste
End If
Next
End Sub
You could try the below code.
The data is being filtered for Column 2 = 0. Only those rows are copied and pasted in the last worksheet
Public Sub CNPPrevOOS()
Worksheets("Bulk Update").Select
a = Worksheets("Bulk Update").Cells(Rows.Count, 1).End(xlUp).Row
'Filters the data where column 2 = 0
ActiveSheet.Range(Cells(1, 1), Cells(a, 2)).AutoFilter Field:=2, Criteria1:="0", Operator:=xlFilterValues
'Select only the filtered cells and copy
Range(Cells(2, 1), Cells(a, 1)).SpecialCells(xlCellTypeVisible).Select
Selection.Copy
ThisWorkbook.Worksheets(ThisWorkbook.Sheets.Count).Select
ActiveSheet.Paste Destination:=Cells(Cells(Rows.Count, 1).End(xlUp).Row + 1, 1)
End Sub
I am copy - pasting values from one worksheet to another. The problem is that I have two merged cells where I want to input my data, these are D:E. Same data from B67 goes to two merged cells which are located in Offset(-1, -1) and Offset(-24, 0)
My code:
Private Sub CommandButton2_Click()
'Paste to a Defined Range
ThisWorkbook.Sheets("Other Data").Range("L67").Copy
'Offset Paste (offsets 2 cells down and 1 to the right
ActiveCell.PasteSpecial xlPasteValues
ThisWorkbook.Sheets("Other Data").Range("B67").Copy
ActiveCell.Offset(-1, -1).PasteSpecial xlPasteValues
ActiveCell.Offset(-24, 0).PasteSpecial xlPasteValues
End Sub
I receive an error on:
ActiveCell.Offset(-1, -1).PasteSpecial xlPasteValues
This cell is located 1 cell up and 1 to the left. If I unmerge this cell the code works fine. However it should be merged to fit my text.
The same with:
ActiveCell.Offset(-24, 0).PasteSpecial xlPasteValues
Hi I think it is connected to the xlpastevalues. Try using xlPasteAll and see if that fixes your issue.
This will work.
Private Sub CommandButton2_Click()
Dim Temp As Variant
Dim R As Long
Temp = ThisWorkbook.Sheets("Other Data").Range("L67").Value
With ActiveCell
R = .Row
If R > 1 And .Column > 1 Then .Offset(-1, -1).MergeArea.Value = Temp
If R > 24 Then .Offset(-24, 0).MergeArea.Value = Temp
End With
End Sub
Since we are copying only values, wouldn't it be easier to just do this?
ActiveCell.Offset(-1, -1) = Range("B67")
Or if the formula is different from the value:
ActiveCell.Offset(-1, -1).Value = Range("B67").Value
PasteValues is the most frustrating thing in VBA! Could greatly use some help.
In short, I am trying to copy one row and pastespecial values that row into another row on a separate sheet. I thought it was a row issue, so I then modified my range and tried pasting that, also to no avail. I even tried recording a macro and the generated code is almost the exact same as mine.
Can someone please help? I've been looking at this too long :/
Sub CopyXs()
Dim counter As Double
Dim CopyRange As String
Dim NewRange As String
counter = 2
For Each Cell In ThisWorkbook.Sheets("LD_Tracker_CEPFA").Range("A7:A500")
If Cell.Value = "X" Then
Sheets("Upload_Sheet").Select
matchrow = Cell.Row
counter = counter + 1
Let CopyRange = "A" & matchrow & ":" & "Y" & matchrow
Let NewRange = "A" & counter & ":" & "Y" & counter
Range(CopyRange).Select
Selection.Copy
Sheets("Final_Upload").Select
ActiveSheet.Range(NewRange).Select
Selection.PasteSpecial Paste = xlPasteValues
Sheets("Upload_Sheet").Select
End If
Next
End Sub
I was struggling also with Paste.Special. This code works for me. The code you get when you record a macro for Paste.Special is not working. You first have to define a range and then used the code for Paste.Special
Range(something).PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
'This code works for me:
'**Select everything on the active sheet**
Range("A1").Select
Dim rangeTemp As Range
Set rngTemp = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious)
If Not rngTemp Is Nothing Then Range(Cells(4, 1), rngTemp).Select
End if
' **Copy the selected range**
Selection.Copy
'**Select the destination and go to the last cel in column A and then go 2 cells down
'and paste the values**
Sheets("your sheet name").Select
Range("A" & Cells.Rows.Count).End(xlUp).Offset(2, 0).PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
**'Select the last cell in column A**
Range("A" & Cells.Rows.Count).End(xlUp).Select
I have used the following code, but it is very specific:
Sub Macro 6 ()
Windows("Projects_Europe2014 work.xlsx").Activate
Range("B12:C16").Select
Selection.Copy
Windows("test1.xlsx").Activate
ActiveSheet.Paste
Windows("Projects_Europe2014 work.xlsx").Activate
Range("D12:E16").Select
Application.CutCopyMode = False
Selection.Copy
Windows("test1.xlsx").Activate
Range("F3").Select
ActiveSheet.Paste
Windows("Projects_Europe2014 work.xlsx").Activate
Range("F12:G16").Select
Application.CutCopyMode = False
Selection.Copy
Windows("test1.xlsx").Activate
Range("J3").Select
ActiveSheet.Paste
End Code
Is there a way, i can keep increasing the range, without manually entering the cde?
Does the worksheet you are copying to contains preexisting data? If not you could just copy your whole range and then insert empty columns where need be - after every two consecutive columns involving data
You can try the below and see if it fits - you need to fill in your references first where commented. "RANGE_REF" is the starting point cell where pasting of the original range should occur
Sub pasteandinsert()
Dim r As Range
Dim r2 As Range
'HERE
Set r = Workbooks("Projects_Europe2014 work.xlsx").Worksheets("YOUR_WS").Range("YOUR_RANGE")
r.Copy
'HERE
With Workbooks("test1.xlsx").Worksheets("YOUR_WS2")
.Activate
'HERE
.Range("RANGE_REF").Select
.Paste
End With
Application.CutCopyMode = False
'HERE
Set r2 = Range("RANGE_REF").Resize(r.Rows.count, r.Columns.count)
i = 3
colcount = r2.Columns.count
Do While i <= colcount
r2.Columns(i).Insert shift:=xlShiftToRight
r2.Columns(i).Insert shift:=xlShiftToRight
i = i + 4
colcount = colcount + 2
Loop
End Sub