I have a code that should restore range formatting after applying few step.
Sub MyCode()
Sheets("My sheet").ListObjects("My Table").DataBodyRange.Copy
...
refreshing connection and calling function that applies stored formulas to table columns
...
Sheets("My sheet").[A10].PasteSpecial Paste:=xlPasteFormats
End sub
I got error PasteSpecial method on range failed
If I paste immediately, it works.
Is it possible to save range formatting as variable?
Here is an example on how to use variables to store the copy method and use it later. You can set the range to a variable CopyRange and use CopyRange.Copy to store it and later you can use it as the range was stored in the CopyRange and not lost along the way due to other processes running down the line.
Option Explicit
Sub CopyDataToTemplate()
Dim ws As Worksheet
Dim srcWB As Workbook
Dim destWB As Workbook
Dim srcWS As Worksheet
Dim destWS As Worksheet
Dim CopyRange As Variant
Dim i As Long, j As Long
Dim srcLRow As Long, destLRow As Long
Set destWB = Excel.Workbooks("DOLine_example.xlsx")
Set srcWB = ActiveWorkbook
Set srcWS = srcWB.ActiveSheet
Set destWS = destWB.Sheets("DOLine")
srcLRow = srcWS.Cells(srcWS.Rows.Count, "A").End(xlUp).Row
destLRow = destWS.Cells(destWS.Rows.Count, "A").End(xlUp).Row
Application.ScreenUpdating = False
'loop through column 1 to 19
For i = 1 To 19
For j = 1 To 13
'loop through columns
If destWS.Cells(3, i).value = srcWS.Cells(1, j).value Then
' Copy column B to Column D as written in your code above
Set CopyRange = srcWS.Range(Cells(2, j), Cells(srcLRow, j))
CopyRange.Copy
' paste columns from one wb to Columns to another wb
destWS.Cells(destLRow, i).PasteSpecial Paste:=xlPasteAll, Transpose:=False
Application.CutCopyMode = False
End If
Next j
Next i
Application.ScreenUpdating = True
MsgBox "Process completed!", vbInformation
End Sub
Related
I want to say thank you for the help I've been getting lately. So I am testing the VBA and I noticed that when I copy and paste data to the worksheet, it would overwrite the hidden rows. Is there a way to copy and paste the data without overwriting the hidden rows?
Public Sub CNPInStock()
Dim ws1 As Worksheet, ws2 As Worksheet
Dim lr1 As Long, lr2 As Long
Set ws1 = ThisWorkbook.Sheets(Sheets.Count) 'Last Worksheet
Set ws2 = ThisWorkbook.Sheets(Sheets.Count - 1) 'Second to Last Worksheet
lr1 = ws1.Range("A" & ws1.Rows.Count).End(xlUp).Offset(1).Row
lr2 = ws2.Range("A" & ws2.Rows.Count).End(xlUp).Row
ws2.Range("A1:C" & lr2).Autofilter Field:=3, Criteria1:=">0", Operator:=xlFilterValues
ws2.Range("A2:C" & lr2).SpecialCells(xlCellTypeVisible).Copy
ws1.Range("A" & lr1).PasteSpecial xlPasteValues
End Sub
It is the same behavior as with normal copy and paste operation done without VBA.
While you can simultaneously copy data from the multiple rows by Selecting visible cells and then Copying, you cannot Paste into multiple regions with one single operation (if some rows are filtered out, this is basically what you are trying to do).
You need to loop with For ... Next through each row to paste the data.
Maybe the following solution will help you:
Sub CNPInStock()
'source-sheet
Dim sws As Worksheet
'target-sheet
Dim tws As Worksheet
Dim i As Long
Dim j As Long
Dim iEnd As Long
Set sws = Sheets("Source")
Set tws = Sheets("Target")
'only for faster calculation
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
'get end of source-sheet
iEnd = sws.Range("A" & sws.Rows.Count).End(xlUp).Row
'init row for target-sheet
j = 1
'loop the source-sheet
For i = 1 To iEnd
'your filter in column 3 with value > 0
If sws.Cells(i, 3).Value > 0 Then
'check if row in target-sheet is hidden
Do Until tws.Rows(j).Hidden = False
j = j + 1
Loop
'copy source to target
sws.Range(Cells(i, 1), Cells(i, 3)).Copy Destination:=tws.Cells(j, 1)
j = j + 1
End If
Next i
'back to automatic (slower) calculation
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
End Sub
I'm wanting to use VBA to copy a range of data from one workbook and paste it in another workbook. To know where to paste the information, I search for the next empty row.
The code works successfully until the last portion when trying to copypaste values. I do not get any errors, or any indication of success or failure. I can see it being copied correctly (the marching dots), and the correct cell is selected, but nothing is pasted.
Sub Button1_Click()
Dim wb1 As Workbook
Dim sht As Worksheet
Dim rng As Range
Dim databasewb As Workbook
Dim databasesht As Worksheet
Dim eRow As Integer
'set workbooks to variables
Set databasewb = Workbooks("Aged Debt Data V1.xlsm")
Set wb1 = Workbooks.Open("C:\Users\roanderson\Desktop\Aged debt\Templates\BIO Inc (IO) Template.xlsx")
'select sheet where data lies
Set sht = wb1.Sheets("Conversion to aged debt format")
sht.Activate
'copy range on sheet
Set rng = sht.Range("A2", Range("A2").End(xlDown).End(xlToRight))
rng.Copy
' paste range into database
'activate database workbook
databasewb.Activate
'find next empty row
eRow = Sheet1.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
MsgBox (eRow)
'paste values into empty row
Sheet1.Cells(eRow, 1).Select
rng.PasteSpecial Paste:=xlPasteValues
wb1.Close
End Sub
The data to be pasted in the Datebase workbook,
When possible, try to avoid using Copy Paste with VBA, as well as avoid using select. Since you just want to copy values, using VBA's Value approach would likely be easier. Modify your line of code where you try to paste special to setting the value. See below
'paste values into empty row
Sheet1.Cells(eRow, 1).Resize(RNG.Rows.Count, RNG.Columns.Count).Value = RNG.Value
wb1.Close
What this is doing starting in Cells(erow,1) the code is using Resize to set the starting range to be the same number of rows and columns or your variable RNG. Then it's just setting the values, the same result as CopyPasteValue only less overhead.
However, if you did want to keep the approach of Copy paste value, then modify your code as such:
'paste values into empty row
Sheet1.Cells(eRow, 1).PasteSpecial Paste:=xlPasteValues
wb1.Close
Change rng.pastespecial to
selection.pastespecial
Performance improvement for copy-paste values. Modular sub.
Bypassing the clipboard is recommended for just Pasting Values. PasteSpecial is less efficient.
See section 8: https://techcommunity.microsoft.com/t5/excel/9-quick-tips-to-improve-your-vba-macro-performance/m-p/173687
Sub CopyPasteSingleCol pastes to PasteFirstRow for Single Column.
sub CopyPasteSingleCol2firstBlank pastes after last blank in column for Single Column.
Sub CopyPasteSingleCol(SrcSheet As Worksheet, ByVal SrcCol As String, ByVal SrcFirstRow As Long, _
PasteSheet As Worksheet, ByVal PasteCol As String, ByVal PasteFirstRow As Long)
Dim SrcLastRow As Long
Dim PasteLastrow As Long
Dim SrcRng As Range
Dim PasteRng As Range
SrcLastRow = SrcSheet.Cells(SrcSheet.Rows.Count, SrcCol).End(xlUp).Row
Set SrcRng = SrcSheet.Range(SrcCol & SrcFirstRow & ":" & SrcCol & SrcLastRow)
Set PasteRng = PasteSheet.Range(PasteCol & PasteFirstRow)
SrcRng.Copy PasteRng
End Sub
Sub CopyPasteSingleCol2firstBlank(SrcSheet As Worksheet, ByVal SrcCol As String, ByVal SrcFirstRow As Long, _
PasteSheet As Worksheet, ByVal PasteCol As String)
Dim SrcLastRow As Long
Dim PasteLastrow As Long
Dim SrcRng As Range
Dim PasteRng As Range
SrcLastRow = SrcSheet.Cells(SrcSheet.Rows.Count, SrcCol).End(xlUp).Row
PasteLastrow = PasteSheet.Cells(PasteSheet.Rows.Count, PasteCol).End(xlUp).Row + 1
' If first row is empty there was not need to add +1 to Lastrow
If PasteSheet.Cells(1, PasteCol) = vbNullString Then PasteLastrow = 1
Set SrcRng = SrcSheet.Range(SrcCol & SrcFirstRow & ":" & SrcCol & SrcLastRow)
Set PasteRng = PasteSheet.Range(PasteCol & PasteLastrow)
SrcRng.Copy PasteRng
End Sub
Sub TESTCopyPasteSingleCol()
Dim SrcSheet As Worksheet
Dim PasteSheet As Worksheet
'Must qualify your Sheet by using Set before calling sub
Set SrcSheet = Workbooks("importGsheettoExcel3.xlsm").Worksheets("SH1")
Set PasteSheet = Workbooks("importGsheettoExcel.xlsm").Worksheets("SH2")
Call CopyPasteSingleCol(SrcSheet, "B", 2, _
PasteSheet, "G", 2)
End Sub
Sub TESTCopyPasteSingleCol2firstBlank()
Dim SrcSheet As Worksheet
Dim PasteSheet As Worksheet
'Must qualify your Sheet by using Set before calling sub
Set SrcSheet = Workbooks("importGsheettoExcel3.xlsm").Worksheets("SH1")
Set PasteSheet = Workbooks("importGsheettoExcel.xlsm").Worksheets("SH2")
Call CopyPasteSingleCol2firstBlank(SrcSheet, "B", 2, _
PasteSheet, "G")
End Sub
I have this code, by a responder who helped me to define my needs yesterday - but there somethings i want to change, but my vba skills are very low and dont know how and where to modify the code. I want it do 2 Things.
Right know it transferes data, i want it to copy it, over with the values that are calculated in the cells. I have some cells, where i have some formulas and it dosent follows with it. I just want the calculated value over. I dont know if i can use xlPasteValues somewhere to get what i want?
The second thing that i want is, when copying over, i want to be on top and the previous copies move Down, so the latest copy always are in the top.
Thank you before handed :)
Option Explicit
Sub Copypastemeddata()
Dim wb As Workbook
Dim ws As Worksheet
Dim sourceCell As Range
Dim targetSheet As Worksheet
Set wb = ThisWorkbook
Set ws = wb.Worksheets("Opgørsel")
Set sourceCell = ws.Range("D3") 'Cell with sheet names for copying to
With ws
Set targetSheet = wb.Worksheets(sourceCell.Text)
Dim nextRow As Long
nextRow = GetLastRow(targetSheet, 1)
nextRow = IIf(nextRow = 1, 1, nextRow + 1)
.Range("A1").CurrentRegion.Copy targetSheet.Range("A" & nextRow)
targetSheet.Columns.AutoFit
End With
End Sub
Public Function GetLastRow(ByVal ws As Worksheet, Optional ByVal columnNumber As Long = 1) As Long
With ws
GetLastRow = .Cells(.Rows.Count, columnNumber).End(xlUp).Row
End With
End Function
Please give this a try...
The StartRow variable defines the destination row on targetSheet, you may change it as per your requirement.
Sub Copypastemeddata()
Dim wb As Workbook
Dim ws As Worksheet
Dim sourceCell As Range
Dim targetSheet As Worksheet
Dim StartRow As Integer
Application.ScreenUpdating = False
Set wb = ThisWorkbook
Set ws = wb.Worksheets("Opgørsel")
Set sourceCell = ws.Range("D3") 'Cell with sheet names for copying to
StartRow = 1 'Destination row on targetSheet
With ws
Set targetSheet = wb.Worksheets(sourceCell.Text)
.Range("A1").CurrentRegion.Copy
targetSheet.Range("A" & StartRow).Insert shift:=xlDown
targetSheet.Range("A" & StartRow).PasteSpecial xlPasteValues
targetSheet.Columns.AutoFit
End With
Application.CutCopyMode = 0
Application.ScreenUpdating = True
End Sub
substitute
Dim nextRow As Long
nextRow = GetLastRow(targetSheet, 1)
nextRow = IIf(nextRow = 1, 1, nextRow + 1)
.Range("A1").CurrentRegion.Copy targetSheet.Range("A" & nextRow)
with
With .Range("A1").CurrentRegion
targetSheet.Rows(1).Resize(.Rows.Count).Insert shift:=xlUp
targetSheet.Range("A1").Resize(.Rows.Count, .Columns.Count).Value = .Value
End With
I have two separate Excel files. In one of these in Sheet1 is stored infomration about orders and order numbers. Now every time I make a new order I want this information be collected from my order and inserted in to so called "database" workbook. It should identify the last empty row in column A:A in C:\Users\user\Desktop\Order_number.xlsx and insert new values from range ("C6,C17,C10,H18,B32,G32,H6,H9") to the next empty row. Here is the code I came up to but there is some mistake and it is not working. How it can be fixed?
Sub TransferValues465()
Dim wsMain As Worksheet: Set wsMain = ThisWorkbook.ActiveSheet
Dim wsData As Worksheet: Set wsData = Workbooks.Open("C:\Users\user\Desktop\Order_number.xlsx").Sheets("Sheet1")
Dim rngToCopy As Range: Set rngToCopy = wsMain.Range("C6,C17,C10,H18,B32,G32,H6,H9")
Dim c As Long
Dim ar As Range
Dim cl As Range
Dim LastRow As Long
Dim rngDestination As Range
With Application
.DisplayAlerts = False
.ScreenUpdating = False
.EnableEvents = False
End With
'Get the last row in Database sheet:
LastRow = wsData.Cells(wsData.Rows.Count, "A").End(xlUp).Row
Set rngDestination = wsData.Cells(LastRow + 1, 1).Resize(1, 25).Offset(0, 0)
For Each ar In rngToCopy.Areas
For Each cl In ar
c = c + 1
'I used this next line for testing:
' rngDestination.Cells(c).Value = cl.Address
rngDestination.Cells(c).Value = cl.Value
Next
Next
End Sub
A few corrections:
1) Set wsData = Workbooks("C:\Users\user\Desktop\Order_number.xlsx").Sheets("Sheet1") will not work. Either use Set wsData = Workbooks("Order_number.xlsx").Sheets("Sheet1") if the workbook is open. Or you need to open the workbook first.
2) I am not famliar on using Application.WorksheetFunction.CountA(wsData.Range("A:A")) to get the last row. To get the last row in Column A (with the possibility of skipping balnk cells in the middle) use wsData.Cells(wsData.Rows.Count, "A").End(xlUp).Row.
3) My preference is to use Copy >> PasteSpecial xlPasteValues with cl.Copy and the following line wsData.Range("A" & C).PasteSpecial xlPasteValues.
Code
Option Explicit
Sub TransferValues465()
Dim wsMain As Worksheet
Dim wbData As Workbook
Dim wsData As Worksheet
Dim rngToCopy As Range
Dim C As Long
Dim ar As Range
Dim cl As Range
Dim LastRow As Long
Dim rngDestination As Range
Set wsMain = ThisWorkbook.ActiveSheet
Application.DisplayAlerts = False
' you need to open the workbook
Set wbData = Workbooks.Open("C:\Users\user\Desktop\Order_number.xlsx")
Set wsData = wbData.Sheets("Sheet1")
Set rngToCopy = wsMain.Range("C6,C17,C10,H18,B32,G32,H6,H9")
'Get the last row in Database sheet:
LastRow = wsData.Cells(wsData.Rows.Count, "A").End(xlUp).Row
C = 1
For Each cl In rngToCopy
cl.Copy
wsData.Cells(LastRow + 1, C).PasteSpecial xlPasteValues
C = C + 1
Next cl
wbData.Close True '<-- close and save the changes made
Application.DisplayAlerts = True '<-- restore settings
End Sub
I have two workbooks. The first workbook(69 worksheets)has old data and the second workbook has new data for some of the worksheets(42 worksheets) of Workbook1. Only the first three columns needs updation in the first workbook. SO I want to create a macro running a loop though Workbook1 from sheet 1 to all the worksheets, finding the same worksheet name in Workbook 2 and copying first three columns and updating them in Workbook1. Can somebody please help me with it.I have created the following code , obviously not working!!
Sub Macro1()
Dim i As Integer
Dim x As Integer
Dim wb2 As Excel.Workbook
Dim rngToCopy As Range
Dim rngToPaste As Range
Set wb2 = Workbooks.Open("D:\Sediment extraction\Analysis\updatedextractedresults_45.xls")
j = ThisWorkbook.Worksheets.Count
k = wb2.Worksheets.Count
For i = 1 To j
For x = 1 To k
If ThisWorkbook.Sheets(i).Name = wb2.Sheets(x).Name Then
wb2.Sheets(x).Activate
Set rngToCopy = ThisWorkbook.Sheets(x).Range("A1",ThisWorkbook.Sheets(x).Range("A65536").End(xlUp)).Resize(, 3)
'With rngToCopy
Set rngToPaste = ThisWorkbook.Sheets(i).Range("A1").Resize(.Rows.Count, .Columns.Count)
End With
'rngToPaste.Value = rngToCopy.Value
End If
Next x
Next i
End Sub
This ought to do the trick:
Option Explicit
Sub UpdateOldDataWorkbook()
Dim NewWb As Workbook, OldWB As Workbook
Dim NewWs As Worksheet, OldWs As Worksheet
Dim LastRow As Long
Dim NewRange As Range, OldRange As Range
'set references up-front
Set NewWb = ThisWorkbook
Set OldWB = Workbooks.Open("D:\Sediment extraction\Analysis\updatedextractedresults_45.xls")
'loop through all the new worksheets in the new workbook
For Each NewWs In NewWb.Worksheets
'find the matching old sheet
If DoesSheetExist(NewWs.Name, OldWB) Then
Set OldWs = OldWB.Worksheets(NewWs.Name)
'collect the new data and assign it to a range for easy copy
With NewWs
LastRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
Set NewRange = Range(.Cells(1, 1), .Cells(LastRow, 3))
End With
'clear the first 3 columns
With OldWs
.Range("A:C").ClearContents
Set OldRange = Range(.Cells(1, 1), .Cells(LastRow, 3))
End With
NewRange.Copy Destination:=OldRange
End If
Next NewWs
End Sub
'this function checks to see if a sheet exists in a target workbook
Public Function DoesSheetExist(dseWorksheetName As Variant, dseWorkbook As Variant) As Boolean
Dim obj As Object
On Error Resume Next
'if there is an error, sheet doesn't exist
Set obj = dseWorkbook.Worksheets(dseWorksheetName)
If Err = 0 Then
DoesSheetExist = True
Else
DoesSheetExist = False
End If
On Error GoTo 0
End Function