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
Related
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 have to preface this by saying I am below the lowest level of novice when it comes to VBA. I currently have a single column of data in excel where information about companies is stored in groups of three rows as you descend down the column. The data is grouped as follows (no empty rows between the data):
CompanyA
www.CompanyA.com
CompanyA location
CompanyB
www.CompanyB.com
CompanyB location... etc.
I need to create a code that will copy the cell below, paste it to cell to the right, then delete the row below. Then copy the cell that is now below, and paste it two to the right, then select the next cell down and repeat for the next three row dataset. I've included my terrible first draft below if this helps explain my thinking. Any help would be very much appreciated. Thank you!
Sub Clean()
Do Until IsEmpty(ActiveCell.Value)
Range("A1").Activate
Selection.Offset(1, 0).Copy
Selection.Offset(0, 1).Paste
ActiveCell.Offset(1, 0).EntireRow.Delete xlShiftUp
Selection.Offset(1, 0).Copy
Selection.Offset(0, 2).Paste
ActiveCell.Offset(1, 0).EntireRow.Delete xlShiftUp
ActiveCell.Offset(1, 0).Select
Loop
End Sub
This could help you do what you want. Not the best solution out there but this will loop through all the cells slightly faster than what you have done.
Sub test()
Dim lRow As Long, i As Long
Dim ws As Worksheet
Dim RowsToDelete As Range
Set ws = ActiveSheet
With ws
lRow = .Cells(.Rows.Count, 1).End(xlUp).Row ' Get the last row
For i = lRow To 1 Step -3
.Cells(i - 2, 3) = .Cells(i, 1)
.Cells(i - 2, 2) = .Cells(i - 1, 1)
If RowsToDelete Is Nothing Then 'first 2 rows to be deleted
Set RowsToDelete = Range(.Rows(i).EntireRow, .Rows(i - 1).EntireRow)
Else 'append more rows with union
Set RowsToDelete = Application.Union(RowsToDelete, .Rows(i).EntireRow, .Rows(i - 1).EntireRow)
End If
Next i
If Not RowsToDelete Is Nothing Then 'if there is something to be deleted
RowsToDelete.Delete
End If
End With
End Sub
You should try to avoid using ActiveCell and Selection in most cases. User input while the code is running can mess up your position and yields unpredictable results.
Its best to pull the data into an array, process your changes and output the data. This method also happens to be faster as you're not constantly reading and writing data to the sheet.
Something like the below will perform better for large data sets and will not be affected by user input during runtime:
Sub GatherCompanyData()
Dim Temp As Variant, Target As Range
Dim x As Long, c As Long, MyOutput As Variant
'First cell containing data [UPDATE THIS AS NEEDED]
Set Target = Sheets("SHEET NAME HERE").Range("A1")
'Get all the data in specified column
With Target.Parent
Temp = .Range(Target.Cells(1, 1).Address, .Cells(.Rows.Count, Target.Column).End(xlUp).Address).Value
End With
'Build Output Data
ReDim MyOutput(1 To Int(UBound(Temp, 1) / 3), 1 To 3)
For x = 3 To UBound(Temp, 1) Step 3
c = c + 1
MyOutput(c, 1) = Temp(x - 2, 1)
MyOutput(c, 2) = Temp(x - 1, 1)
MyOutput(c, 3) = Temp(x, 1)
Next x
'Clear existing data and output new data
Target.Value = Empty
Target.Resize(c, 3).Value = MyOutput
End Sub
I think I actually just figured it out. I'm sure this isn't the most elegant solution but it works. Curious if anyone has a better way of solving this. Thanks!
Sub Clean()
Range("A1").Activate
Do Until IsEmpty(ActiveCell.Value)
Selection.Offset(1, 0).Copy
Selection.Offset(0, 1).Select
ActiveCell.PasteSpecial xlPasteAll
ActiveCell.Offset(1, 0).EntireRow.Delete xlShiftUp
Selection.Offset(1, -1).Select
ActiveCell.Copy
Selection.Offset(-1, 2).Select
ActiveCell.PasteSpecial xlPasteAll
ActiveCell.Offset(1, 0).EntireRow.Delete xlShiftUp
Selection.Offset(1, -2).Select
Loop
End Sub
I made this code to copy data from Sheet1 to Sheet2 if the color of the cell is green (after conditional formatting it turns green). But it is giving me error in the color condition. Any suggestions ?
Private Sub CommandButton1_Click()
a = Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To a
If Worksheets("Sheet1").Interior.ColorIndex = 14 Then
Worksheets("Sheet1").Rows(i).Copy
Worksheets("Sheet2").Activate
b = Worksheets("Sheet2").Cells(Rows.Count, 1).End(xlUp).Row
Worksheets("Sheet2").Cells(b + 1, 1).Select
ActiveSheet.Paste
Worksheets("Sheet1").Activate
End If
Next
Application.CutCopyMode = False
ThisWorkbook.Worksheets("Sheet1").Cells(1, 1).Select
End Sub
Few things to consider, the For Loop will iterate through column A of Sheet1 and copy the full row to Sheet2 in the next available row, if it meets the criteria:
Private Sub CommandButton1_Click()
a = Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To a
b = Worksheets("Sheet2").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
If Worksheets("Sheet1").Cells(i, "A").Interior.ColorIndex = 14 Then
Worksheets("Sheet1").Rows(i).Copy
Worksheets("Sheet2").Range("A" & b).PasteSpecial xlPasteAll
Application.CutCopyMode = False
End If
Next i
End Sub
You set
Application.CutCopyMode = False
So there is nothing in the buffer to paste. Move that line to after the PasteSpecial
You'd be better off not copying and pasting. When you copy/paste you muck with the user's copy/paste buffer. It's generally better to assign values and other aspects directly:
myTargetRange.Value = mySourceRange.Value
myTargetRange.Formula = mySourceRange.Formula
myTargetRange.RowHeight = mySourceRange.RowHeight
etc.
I have 2 sheets, sheet 1 has a cell with total price formula on it. I want to copy that cell on sheet 1 to sheet 2 column G2 going down every time I click on the macro (UPDATE button) with a new price total.
I have tried recording a macro but whenever I click the update button it paste the cell but with a REF! error or a value 0.
can anyone help me.
thanks
range("b3").select
application.cutcopypaste=false
selection.copy
sheets("sheets2").select
range("b4").select
selection.insert shift:=xldown
This is the simplest answer:
Sheets("Source Sheet Name").Range("B3").Copy
Sheets("Destination Sheet Name").Range("G" & Range("G" & Rows.Count).End(xlUp).Row + 1).Paste
Variant without copy
Sub test()
Sheets("Sheet2").Cells(Rows.Count, 7).End(xlUp).Offset(1, 0).Value = Sheets("Sheet1").Range("B3").Value
End Sub
Variant with copy method
Sub test2()
Sheets("Sheet1").Range("B3").Copy Sheets("Sheet2").Cells(Rows.Count, 7).End(xlUp).Offset(1, 0)
End Sub
Another one vatiant using copy method
Sub test3()
Sheets("Sheet1").[B3].Copy
Sheets("Sheet2").Cells(Rows.Count, "G").End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
End Sub
I have a nightmare task to migrate from one accounting package to another.
I have 9340 rows in columns A,B and G which needs to be ordered in a certain way before it can be imported by new system.
Before:
After:
I ran a macro that does what I want but only for selected range. How do I make macro work for entire sheet?
Sub Macro1()
Range("B206").Select
Selection.Cut
Range("A207").Select
ActiveSheet.Paste
Rows("206:206").Select
Selection.Delete Shift:=xlUp
Range("A206").Select
Selection.Copy
Range("A206:A216").Select
ActiveSheet.Paste
Range("C216").Select
Application.CutCopyMode = False
Selection.Cut
Range("G216").Select
ActiveSheet.Paste
End Sub
This will likely fail in some respect. Your setup is more complicated than I have time to re-create. Please run this code on a copy of your data. It basically moves things around and then deletes all the rows that have blanks in column B. You should delete the header junk above the first "Opening" row:
Sub test()
Dim ws As Excel.Worksheet
Dim LastRow As Long
Dim cell As Excel.Range
Set ws = ActiveSheet
With ws
LastRow = .Range("B" & .Rows.Count).End(xlUp).Row
For Each cell In .Range("B1:B" & LastRow)
If Left(cell.Value, Len("Opening")) = "Opening" Then
cell.Offset(1, -1).Value = cell.Value
cell.ClearContents
Else
cell.Offset(0, -1) = cell.Offset(-1, -1).Value
End If
If Left(cell.Value, Len("Closing")) = "Closing" Then
cell.Offset(0, 6).Value = cell.Offset(0, 1).Value
cell.Offset(0, 1).ClearContents
End If
Next cell
.Range("B" & .Rows.Count).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End With
End Sub