I have Workbook, source.xlsm, Worksheet "test1" Column A6:A20 that I need to copy to another WorkBook located on my C:... named dest.xlsx, Worksheet "Assets", Column "I". I need to be able to copy the data and be able to add to the column without overwriting the previous data copied. Any help would be a life saver.
Sub Align()
Dim TargetSh As String
TargetSh = "Assets"
For Each WSheet In Application.Worksheets
If WSheet.Name <> TargetSh Then
WSheet.Select
Range("A6:A20").Select
Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
Selection.Copy
Sheets(TargetSh).Select
lastRow = Range("I65532").End(xlUp).Row
Cells(lastRow + 1, 1).Select
ActiveSheet.Paste
End If
Next WSheet
End Sub
Is this what you are trying? I have not tested it but I think it should work. Let me know if you get any errors.
Sub Sample_Copy()
Dim wb As Workbook, wbTemp As Workbook
Dim ws As Worksheet, wsTemp As Worksheet
Dim lastRow As Long
Set wb = ThisWorkbook
Set ws = wb.Sheets("test1")
'~~> Change path as applicable
Set wbTemp = Workbooks.Open("C:\dest.xlsx")
Set wsTemp = wbTemp.Sheets("Assets")
lastRow = wsTemp.Range("I" & Rows.Count).End(xlUp).Row + 1
ws.Range("A6:A20").Copy wsTemp.Range("I" & lastRow)
Application.CutCopyMode = False
'~~> Cleanup
wbTemp.Close savechanges:=True
Set wb = Nothing: Set wbTemp = Nothing
Set ws = Nothing: Set wsTemp = Nothing
End Sub
HTH
Sid
Related
I have 200 sheets in 1 workbook with an average of 65,000 records on each sheet. I am trying to build a macro that merges all sheets in 1 Excel file into the minimum number of sheets on a NEW Excel file. As Excel has a limitation of 1.xxx million records, the new file would have to have more than 1 sheet, but I am looking to consolidate as much as possible on the new file/tabs.
Below is what I have built so far, but I am struggling to even copy and past the data properly, let alone adding new sheets whenever needed.
Is anyone able to assist?
Sub Combine()
Dim J As Integer
Dim s As Worksheet
Dim wb As Workbook
Set wb = ActiveWorkbook
Set ws = wb.ActiveSheet
Sheets(1).Select
'Opens initial file
strFile = Application.GetOpenFilename
Workbooks.Open strFile
Set INITIALFILE = ActiveWorkbook
' copy headings
Sheets(1).Activate
Range("A1").EntireRow.Select
Selection.Copy
wb.Sheets("Sheet1").Activate
Sheets("Sheet1").Range("A" & Sheets(1).Rows.Count).End(xlUp).Offset(0, 0).PasteSpecial
INITIALFILE.Activate
For Each s In ActiveWorkbook.Sheets
If s.Name <> "Combined" Then
Application.GoTo Sheets(s.Name).[a1]
Selection.CurrentRegion.Select
' Don't copy the headings
Selection.Offset(1, 0).Resize(Selection.Rows.Count - 1).Select
Selection.Copy
wb.Sheets("Sheet1").Activate
Sheets("Sheet1").Range("A" & Sheets(1).Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial
INITIALFILE.Activate
End If
Next
End Sub
If you use Range object variables, you rarely need to use Select and your screen will be much the quieter. As noted using a general On Error Resume Next will make it almost impossible to make your code work properly as you will not see useful error messages.
Sub Combine()
Dim NewFile As Workbook
Dim InitialFile As Workbook
Const RowLimit As Long = 1000000
Dim strFile As String
Dim InRows As Long
Dim OutRows As Long
Dim FirstSheet As Worksheet
Dim OutSheet As Worksheet
Dim ASheet As Worksheet
Dim CopySet As Range
Dim OutLoc As Range
Dim Anon As Variant
Set NewFile = ActiveWorkbook
Set FirstSheet = NewFile.Sheets.Add(After:=Sheets(Sheets.Count))
Set OutSheet = FirstSheet
Set OutLoc = OutSheet.Range("A1")
'Opens initial file
strFile = Application.GetOpenFilename
Workbooks.Open strFile
Set InitialFile = ActiveWorkbook
OutSheet.Activate
For Each ASheet In InitialFile.Sheets
Anon = DoEvents()
If ASheet.Name <> "Combined" Then
Set CopySet = ASheet.Cells.SpecialCells(xlCellTypeLastCell)
If CopySet.Row + OutLoc.Row > RowLimit Then
Set OutSheet = NewFile.Sheets.Add(After:=OutSheet)
Set OutLoc = OutSheet.Range("A1")
End If
' Only copy the headings if needed
If OutLoc.Row = 1 Then
Set CopySet = Range(ASheet.Range("A1"), CopySet)
Else
Set CopySet = Range(ASheet.Range("A2"), CopySet)
End If
CopySet.Copy OutLoc
Set OutLoc = OutLoc.Offset(CopySet.Rows.Count, 0)
End If
Next ASheet
FirstSheet.Activate
End Sub
The call to DoEvents() is there to keep the screen current rather than frozen in some half-drawn fashion.
The code from this forum is what I used as a starting point. I am trying to modify it to copy multiple sheets and paste them all as values, instead of just one sheet.
I copied multiple sheets using worksheets(array(1,2,3)).copy. I think the problem is With ActiveSheet.UsedRange because it is only replacing the first sheet as values and leaving the remaining sheets as formulas.
What do I need to change so that all the sheets paste as values?
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Application.DisplayAlerts = False
Worksheets(Array("Sheet 1","Sheet 2","Sheet 3").Copy
With ActiveSheet.UsedRange
.Value = .Value
End With
Set wbNew = ActiveWorkbook
wbNew.SaveAs "L:\Performance Data\UK Sales\Sales (Latest).xlsx"
wbNew.Close True
Application.DisplayAlerts = True
End Sub
You need to loop through the sheets:
Dim ws As Worksheet
For Each ws In ActiveWorkbook.Worksheets
ws.UsedRange.Value = ws.UsedRange.Value
Next ws
So, with your code, you could do it like this:
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Dim wbOld As Workbook, wbNew As Workbook
Dim ws As Worksheet, delWS As Worksheet
Dim i As Long, lastRow As Long, lastCol As Long
Dim shts() As Variant
Dim rng As Range
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set wbOld = ActiveWorkbook
shts() = Array("Sheet 1", "Sheet 2", "Sheet 3")
Set wbNew = Workbooks.Add
Set delWS = ActiveSheet
wbOld.Worksheets(Array("Sheet 1", "Sheet 2", "Sheet 3")).Copy wbNew.Worksheets(1)
delWS.Delete
For i = LBound(shts) To UBound(shts)
With wbNew.Worksheets(shts(i))
lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
lastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
Set rng = .Range(.Cells(1, 1), .Cells(lastRow, lastCol))
rng.Value = rng.Value
End With
Next i
wbNew.SaveAs "L:\Performance Data\UK Sales\Sales (Latest).xlsx"
wbNew.Close True
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Note: I am not sure which workbook you want to paste the values in. As it is above, it does this in the COPIED workbook, not original.
I found this great Macro that copies each of my rows in my data frame separately into a new sheet, but keeps the first row with the column names as well:
Sub abc_01()
Dim WS As Worksheet, newWS As Worksheet
Dim X As String
Application.ScreenUpdating = False
Set WS = Sheets("Sheet1")
On Error Resume Next
X = InputBox("number of names 1,2,", , "9")
For i = 1 To X
Set newWS = Worksheets.Add(after:=Worksheets(Worksheets.Count))
WS.Range("A1:G1").Copy Destination:=newWS.Range("A1")
WS.Range(WS.Cells(i + 1, "A"), WS.Cells(i + 1, "G")).Copy
newWS.Range("A2").PasteSpecial xlValues
Next i
On Error GoTo 0
Application.ScreenUpdating = True
End Sub
I tried now to copy it into a new workbook rather than a new sheet, but the new workbook stays empty when I run it. Also, I haven't saved the new workbooks yet as a new filename (ideally a specific cell value if possible?)
Sub abc_02()
Dim thisWB As String
Dim newWB As String
thisWB = ActiveWorkbook.Name
Dim X As String
Application.ScreenUpdating = False
Set WS = Sheets("Sheet1")
On Error Resume Next
X = InputBox("number of names 1,2,", , "9")
For i = 1 To X
Workbooks.Add
ActiveWorkbook.SaveAs supName
newWB = ActiveWorkbook.Name
Windows(thisWB).Activate
Sheets("Sheet1").Select
Range("A1:G1").Copy
Windows(newWB).Activate
Sheets("Sheet1").Select
ActiveSheet.Range("A1").Select
ActiveSheet.Range("A1").Paste
Windows(thisWB).Activate
Sheets("Sheet1").Select
Range(Sheet1.Cells(i + 1, "A"), Sheet1.Cells(i + 1, "G")).Copy
Windows(newWB).Activate
Sheets("Sheet1").Select
Range("A2").PasteSpecial xlValues
Next i
On Error GoTo 0
Application.ScreenUpdating = True
End Sub
I am a VBA noob so any help much appreciated!
In the original code, you have
Dim WS As Worksheet, newWS As Worksheet
Dim X As String
Dim WS as Worksheet and newWS as Worksheet tells Excel "WS and newWS will be worksheets."
Later in the code, these are set respectively, WS as Sheet1 in the active workbook, and newWS as a new worksheet within the active workbook.
Changing
Dim thisWB As String
Dim newWB As String
to
Dim thisWB As Workbook
Dim newWB As Workbook
should fix your issue.
You should be dimming thisWB and newWB as Workbooks, not strings.
Excel will be looking for a string of text instead of Workbooks.
Also - try looking on ExcelForum.com VBA section; I learnt a lot of what I know from there.
Hope that helps
I try to copy a range from a workbook (opened with vba-excel) to another (thisworkbook)
Public wbKA as workbook
Sub A()
Dim oExcel As Excel.Application
KAPath = ThisWorkbook.path & "\Data.xlsx"
Set oExcel = New Excel.Application
Set wbKA = oExcel.Workbooks.Open(KAPath)
...
End Sub
with this code:
Sub Get()
Dim LastRow As Long
With wbKA.Worksheets("Sheet1")
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
.Range(.Cells(5, 1), .Cells(LastRow, 1)).Copy
.Range(.Cells(5, 1), .Cells(LastRow, 1)).Copy Destination:=ThisWorkbook.Worksheets("SheetB").Range("A6")
The line .Range(.Cells(5, 1), .Cells(LastRow, 1)).Copy Destination:=ThisWorkbook.Worksheets("SheetB").Range("A6") is highlighted (yellow) by the debugger with the error that the copy method could not be applyed to the range object. The first copy method (just insered by me to check if the error occurs without the Destination part) runs through. I copied the code to another workbook where I apply the copy-destination copy pattern to only one workbook and it is working. Could anyone tell me, why this is not working? The wbKA workbook opens up fine and I can actually perform all I need (Search, Pasting Values into arrays and so on), just the Copy thing doesnt work.
Since you are working from Excel, you do not need to open a new instance. That is creating the copy issues. Try this (Untested)
Sub Sample()
Dim thisWb As Workbook, thatWb As Workbook
Dim thisWs As Worksheet, thatWs As Worksheet
Dim KAPath As String
Dim LastRow As Long
Set thisWb = ThisWorkbook
Set thisWs = thisWb.Sheets("SheetB")
KAPath = ThisWorkbook.Path & "\Data.xlsx"
Set thatWb = Workbooks.Open(KAPath)
Set thatWs = thatWb.Sheets("Sheet1")
With thatWs
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
.Range(.Cells(5, 1), .Cells(LastRow, 1)).Copy thisWs.Range("A6")
End With
End Sub
Followup from comments.
You cannot use rng.copy Dest.rng when working with different Excel instances. You will have to first copy it and then paste in the next line. See these examples
This will not work
Sub Sample()
Dim xl As New Excel.Application
Dim wb As Workbook
Dim ws As Worksheet
xl.Visible = True
Set wb = xl.Workbooks.Add
Set ws = wb.Sheets(1)
ws.Range("A1").Value = "Sid"
ws.Range("A1").Copy ThisWorkbook.Sheets(1).Range("A1")
End Sub
This will work
Sub Sample()
Dim xl As New Excel.Application
Dim wb As Workbook
Dim ws As Worksheet
xl.Visible = True
Set wb = xl.Workbooks.Add
Set ws = wb.Sheets(1)
ws.Range("A1").Value = "Sid"
ws.Range("A1").Copy
ThisWorkbook.Sheets(1).Range("A1").PasteSpecial xlValues
End Sub
I have looked through this website and got a code similar to this.
My problem is that the code is opening the files but not pasting the data.
The workbook where I am trying to paste the data is TRY 5.xlsm and the range where I am pasting is B3. I am copying the data from workbook Copy of BAFD.xlsx and the range is V1:AF1.
Sub CopyData()
Dim wb1 As Workbook, wb2 As Workbook
Dim ws1 As Worksheet, ws2 As Worksheet
Set wb1 = Workbooks.Open("C:\Documents and Settings\43707844\Desktop\Change of weights\Svar\BAFD\Copy of BAFD.xlsx")
Set wb2 = Workbooks.Open("C:\Documents and Settings\43707844\Desktop\Change of weights\Svar\BAFD\Practise\TRY 5.xlsm")
Set ws1 = wb1.Sheets("Calib_30Nov")
Set ws2 = wb2.Sheets("Calib29_30")
With ws1.Range("V1:AF1").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
ws2.Range("B3").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
End With
End Sub
You don't need to select anything or use that With statement - does this work?
Sub CopyData()
Dim wb1 As Workbook, wb2 As Workbook
Dim ws1 As Worksheet, ws2 As Worksheet
Set wb1 = Workbooks.Open("C:\Documents and Settings\43707844\Desktop\Change of weights\Svar\BAFD\Copy of BAFD.xlsx")
Set wb2 = Workbooks.Open("C:\Documents and Settings\43707844\Desktop\Change of weights\Svar\BAFD\Practise\TRY 5.xlsm")
Set ws1 = wb1.Sheets("Calib_30Nov")
Set ws2 = wb2.Sheets("Calib29_30")
ws1.Range("V1:AF1", ws1.Range("V1:AF1").End(xlDown)).Copy
ws2.Range("B3").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
End Sub
EDIT: OK let's take a different approach, we'll define 2 range objects and transfer the values programatically rather than using Copy / Paste:
Sub CopyData()
Dim wb1 As Workbook, wb2 As Workbook
Dim ws1 As Worksheet, ws2 As Worksheet
Dim rngCopy As Range, rngPaste As Range
Set wb1 = Workbooks.Open("C:\Documents and Settings\43707844\Desktop\Change of weights\Svar\BAFD\Copy of BAFD.xlsx")
Set wb2 = Workbooks.Open("C:\Documents and Settings\43707844\Desktop\Change of weights\Svar\BAFD\Practise\TRY 5.xlsm")
Set ws1 = wb1.Sheets("Calib_30Nov")
Set ws2 = wb2.Sheets("Calib29_30")
Set rngCopy = ws1.Range("V1:AF1", ws1.Range("V1:AF1").End(xlDown))
Set rngPaste = ws2.Range("B3").Resize(rngCopy.Rows.Count, rngCopy.Columns.Count)
rngPaste.Value = rngCopy.Value
End Sub
EDIT - This should now work through the sheets and copy the data across for each one:
Sub CopyData()
Dim wb1 As Workbook, wb2 As Workbook
Dim ws1 As Worksheet, ws2 As Worksheet
Dim rngCopy As Range, rngPaste As Range
Dim strWs1 As String, strWs2 As String, i As Integer, arrSheets() As String
Dim blnExists1 As Boolean, blnExists2 As Boolean
Set wb1 = Workbooks.Open("C:\Documents and Settings\43707844\Desktop\Change of weights\Svar\BAFD\Copy of BAFD.xlsx")
Set wb2 = Workbooks.Open("C:\Documents and Settings\43707844\Desktop\Change of weights\Svar\BAFD\Practise\TRY 5.xlsm")
'Put all BAFD.xlsx worksheet names into a string array so we can check that they exist
ReDim arrSheets(wb1.Worksheets.Count)
For i = 1 To wb1.Worksheets.Count
arrSheets(i) = wb1.Worksheets(i).Name
Next
'Loop through all sheets in TRY 5, identify numbers and transfer data across
For Each ws2 In wb2.Worksheets
Debug.Print "WS2 Name: " & ws2.Name
strWs1 = Mid(ws2.Name, 5, 2)
strWs2 = Mid(ws2.Name, 8, 2)
Debug.Print "WS2 1 Number: " & strWs1
Debug.Print "WS2 2 Number: " & strWs2
blnExists1 = False
blnExists2 = False
'Check that sheets exist in BAFD.xlsx
For i = LBound(arrSheets) To UBound(arrSheets)
If arrSheets(i) = "Calib_" & strWs1 Then blnExists1 = True
If arrSheets(i) = "Calib_" & strWs2 Then blnExists2 = True
Next
Debug.Print "WS1 Exists: " & blnExists1
Debug.Print "WS2 Exists: " & blnExists2
'If both exist, copy the values across. If they don't, move on to the next one
If blnExists1 = True And blnExists2 = True Then
'Get first sheet details
Set ws1 = wb1.Sheets("Calib_" & strWs1)
Set rngCopy = ws1.Range("V1:AF1", ws1.Range("V1:AF1").End(xlDown))
Set rngPaste = ws2.Range("B3").Resize(rngCopy.Rows.Count, rngCopy.Columns.Count)
rngPaste.Value = rngCopy.Value
'Get second sheet details
Set ws1 = wb1.Sheets("Calib_" & strWs2)
Set rngCopy = ws1.Range("V1:AF1", ws1.Range("V1:AF1").End(xlDown))
Set rngPaste = ws2.Range("N3").Resize(rngCopy.Rows.Count, rngCopy.Columns.Count)
rngPaste.Value = rngCopy.Value
End If
Next
End Sub