In my first active workbook, column A has a list of numbers, starting in cell A1, and listing down a varied number of rows each time.
I would like to copy all of the column A cells containing information into another workbook (if the second workbook could remain closed during the process that would be preferable).
My desired paste location in the second workbook would be column A in the first empty row available. i.e. I want this second workbook to be a list of all of the data column A of the first workbook has ever had.
Paste this Code into a new Module in the VBA Editor of the Workbook which has the Source Data (Open VBA Editor: ALT+F11) and run the Macro "CopyToAnotherWorkbook".
before running, specify the Destination Workbook Path, hint is in the code.
Sub CopyToAnotherWorkbook()
Application.ScreenUpdating = False
Dim wb As Workbook: Set wb = ThisWorkbook
Dim ws As Worksheet: Set ws = wb.ActiveSheet
Dim LastRow_wb%: LastRow_wb = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
Dim arr() As Variant
ReDim arr(0 To LastRow_wb - 1)
For i = 1 To LastRow_wb
arr(i - 1) = ws.Cells(i, 1)
Next i
Dim wb2 As Workbook: Set wb2 = Workbooks.Open("C:\Book2.xlsx") ' <- Paste your Link to the Workbook here!
Dim ws2 As Worksheet: Set ws2 = wb2.Sheets(1)
Dim LastRow_wb2%: LastRow_wb2 = ws2.Cells(ws2.Rows.Count, "A").End(xlUp).Row + 1
If LastRow_wb2 = 2 Then
LastRow_wb2 = 1
End If
ws2.Range("A" & LastRow_wb2 & ":A" & LastRow_wb2 + UBound(arr)).Value = WorksheetFunction.Transpose(arr)
Application.ScreenUpdating = True
wb2.Close True
Set ws2 = Nothing
Set wb2 = Nothing
Set ws = Nothing
Set wb = Nothing
End Sub
Related
I have got a worksheet with some data. I store that data in an array and then I want to create a new worksheet and save the data into a new worksheet.
Right now I'm creating a new sheet in the workbook of origin data like this:
Sub New_workbook()
Dim sh as Worksheet, origin as Worksheet, arr
origin = Sheets("OriginSheet")
sh = ActiveSheet
somedata = origin.Range("A1:C").Value
ReDim arr(1 To 100, 1 To 3)
For i = 1 To 100
arr(i, 1) = somedata(i, 1)
arr(i, 2) = somedata(i, 2)
arr(i, 3) = somedata(i, 3)
Next i
sh.Range("A2").Resize(UBound(arr), UBound(arr, 2)).Value = arr
End Sub
and instead of sh = ActiveSheet, I would like to have something like sh = NewWorkbook("Name_of_new_workbook") and create a workbook in the directory of OriginSheet workbook or given path and fill it with arr values. How can I do this in VBA?
If you are looking to copy all the data in your source range, it isn't necessary to store that data in an array first. Just Set your range and make the value of the destination range equal the value of the source range. Try something like this:
Sub CopyRangeIntoNewWorkbook()
'disabling screen update and calculation to speed things up
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim wb As Workbook, wb_new As Workbook
Dim ws As Worksheet
Dim rng As Range
Set wb = ActiveWorkbook
Set ws = ActiveSheet
'set the rng for which you want to copy the values
Set rng = ws.Range("A1:C10")
'set wb_new to newly added wb
Set wb_new = Workbooks.Add()
'specify the top left cell of the range you want to have populated in the new wb
wb_new.Sheets(1).Range("A1").Resize(rng.Rows.Count, rng.Columns.Count).Value2 = rng.Value2
'save file, here using path of your original wb'
wb_new.SaveAs Filename:=wb.path & "\wb_new.xlsx"
'closing the new file
wb_new.Close saveChanges:=False
'enabling screen update and automatic calculation again
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
The most eficient way to copy a sheet content in a new workbook should be the next one:
Sub New_workbook()
Dim origin As Worksheet
Set origin = Sheets("OriginSheet") 'an object must be Set
origin.Copy 'this will create a new workbook with the content of the copied sheet
ActiveWorkbook.saveas origin.Parent.path & "\" & "Name_of_new_workbook" & ".xlsx", xlWorkbookDefault
End Sub
If needing to keep only columns "A:C", you can add the next code lines:
Dim sh As Worksheet, lastCol As Long
Set sh = ActiveWorkbook.Worksheets(1)
lastCol = sh.cells.SpecialCells(xlCellTypeLastCell).Column
If lastCol <= 3 Then Exit Sub
If lastCol = 4 Then sh.cells(1, 4).EntireColumn.Delete: Exit Sub
sh.Range(sh.cells(1, 4), sh.cells(1, lastCol)).EntireColumn.Delete
Below is my original code. I am trying to change my code so that add/delete new columns/rows won't affect the new created workbook. I decided to use the name range to avoid the code crushed. (I know how to create the new range in the Name manager) Anyone knows how to adjust the code?
Dim WS As Worksheet
Dim Rng As Range
Dim myWs As Worksheet
Set myWs = ThisWorkbook.Sheets("MASTER")
Set Rng1 = myWs.Range("A1:AJ4")
Set Rng2 = myWs.Range("A85:AJ104")
Application.Workbooks.Add
Set WS = Application.ActiveSheet
Rng1.Copy Destination:=WS.Range("A1:AJ4")
Rng2.Copy Destination:=WS.Range("A5:AJ50")
You need to dim each workbook and worksheet you will be using.
Dim wb1 as Workbook, wb2 as Workbook, ws1 as Worksheet, ws2 as Worksheet
Dim xrow as long, arrData() as variant
Set wb1 = Workbooks("Book1")
Set ws1 = wb1.Worksheets("Sheet1")
Set wb2 = Workbooks("Book2")
Set ws2 = wb2.Worksheets("Sheet2")
Note that this only works if you have both workbooks open.
Also I would recommend copying the data from each cell to an array, instead of copying a range. I get less errors this way.
ApplicationScreenUpdating = False
ws1.Activate
'where n is the number of rows you want to copy
for x = 1 To n
arrData[x - 1] = ws1.Cells(x, 1).value
next x
ws2.Activate
for i = 1 to n
ws2.Cells(i, 1).value = arrData[i - 1]
next i
ApplicationScreenUpdating = True
I'm looking to paste some cells from one closed workbook to another workbook.
I have managed to paste a couple of cells successfully, however, I want to copy cells starting at D9, and then every 9th until empty cells are found on SourceWb, and paste them in the other workbook TargetWb starting at column A, row 2, and so on horizontally (B2, C2, D2, etc)
Sub PullClosedData()
Dim filePath As String
Dim SourceWb As Workbook
Dim TargetWb As Workbook
Set TargetWb = ActiveWorkbook
filePath = TargetWb.Sheets("System").Range("A1").Value
Set SourceWb = Workbooks.Open(filePath)
SourceWb.Sheets("results").Range("D9").Copy
Destination:=TargetWb.Sheets("Data").Range("A2")
SourceWb.Sheets("results").Range("D18").Copy
Destination:=TargetWb.Sheets("Data").Range("B2")
SourceWb.Save
TargetWb.Save
TargetWb.Close False
MsgBox "Complete!"
End Sub
Thanks in advance for your support.
You need to use a dynamic Variant Array, and dynamic range.
Sub PullClosedData()
Dim filePath As String
Dim SourceWb As Workbook
Dim TargetWb As Workbook
Dim sWs As Worksheet, tWs As Worksheet
Dim i As Long, n As Long, r As Long, vR() As Variant
Set TargetWb = ActiveWorkbook
filePath = TargetWb.Sheets("System").Range("A1").Value
Set SourceWb = Workbooks.Open(filePath)
Set sWs = SourceWb.Sheets("resuts")
Set tWs = TargetWb.Sheets("Data")
With sWs
r = .Range("d" & Rows.Count).End(xlUp)
For i = 9 To r Step 9
n = n + 1
ReDim Preserve vR(1 To n) '<~~ increase dynamic array.
vR(n) = .Range("d" & i)
Next i
End With
tWs.Range("a2").Resize(1, n) = vR
SourceWb.Save
TargetWb.Save
TargetWb.Close False
MsgBox "Complete!"
End Sub
I'm currently doing VBA project which need to copy from a workbook to another, which the WBookPst is the workbook I firstly open (use) meanwhile WBookCopy is the workbook where I open based on the links where I got by listing all ".xslt" format in a File into my Sheet1 of my first workbook. Here is my code :
Sub SortFiles()
'Set up your variables and turn off screen updating.
'Dim iCounter As Integer
Application.ScreenUpdating = False
'Sort the rows based on the data in column C
Columns("A:C").Sort key1:=Range("C2"), _
order1:=xlDescending, Header:=xlYes
Application.ScreenUpdating = True
Dim WBookCopy As Workbook
Dim WBookPst As Workbook
Dim filePath As String
Dim sheetName As String
Dim sheetCopy As Worksheet
Dim sheetPate As Worksheet
Dim rngCopy As Range
Dim rngPst As Range
filePath = Range("B2").Value
Set WBookCopy = Workbooks.Open(filePath)
Columns(30).Insert
For i = 1 To Sheets.count
Cells(i, 30) = Sheets(i).Name
Next i
sheetName = Range("AD1").Value
Set sheetCopy = WBookCopy.Worksheets(sheetName)
Set rngCopy = sheetCopy.Range("A:AA").Copy
Set WBookPst = ThisWorkbook
Set sheetPaste = WBookPst.Worksheets("Sheet1").Activate
Set rngCopy = sheetPaste.Range("A:AA").Select
ActiveSheet.Paste
End Sub
At Set rngCopy = sheetCopy.Range("A:AA").Copy there's error "Objects required".
What does that mean?
By the way, is how I copy and paste the data between sheets correct?
The issue is that rngCopy is of type range and you can't set it equal to a method (copy). Remove the .Copy and you should be fine. You also don't need to set the worksheet out range to a variable. You could just do one line that says WBookCopy.SheetName.Range("A:AA").Copyand then another line to paste.
As #Wyatt mentioned - your copy\paste syntax is incorrect
Here are 2 ways to do it:
Worksheets("Sheet1").Range("A:AA").Copy
Worksheets("Sheet2").Range("A1").PasteSpecial xlPasteAll
or
Worksheets("Sheet1").Range("A:AA").Copy Destination:=Worksheets("Sheet2").Range("A1")
Long time reader and admirer of StackOverflow.
Basically I am trying to to loop through a series of Excel files to copy a range of data and paste it on a single Excel workbook/sheet.
The cell range location (C3:D8, D3:E8) is not always consistent, but the table dimensions are: 29 R x 2 C. Also, the files only have 1 sheet, and aside from the table dimensions specified, no data values in other cells.
In its current form the code is executing, but not pasting anything to its destination Excel file.
I need it to
Find the data dimension in file (table)
Copy the table
Paste to destination (below previous table)
Loop through to next file
Repeat Step 1-4
The code is from:
Excel VBA: automating copying ranges from different workbooks into one final destination sheet?
Thanks a lot for any help, I really appreciate it and please feel tell me to specify anything if my question is vague.
Sub SourcetoDest()
Dim wbDest As Workbook
Dim wbSource As Workbook
Dim sDestPath As String
Dim sSourcePath As String
Dim shDest As Worksheet
Dim rDest As Range
Dim vaFiles As Variant
Dim i As Long
'array of folder names under sDestPath
'array of file names under vaFiles
vaFiles = Array("Book1.xls")
sDestPath = "C:\Users"
sSourcePath = "C:\Users"
Set wbDest = Workbooks.Open(sDestPath & "\" & "Book2.xlsm")
Set shDest = wbDest.Sheets(1)
'loop through the files
For i = LBound(vaFiles) To UBound(vaFiles)
'open the source
Set wbSource = Workbooks.Open(sSourcePath & "\" & vaFiles(i))
'find the next cell in col C
Set rDest = shDest.Cells(shDest.Rows.Count, 3).End(xlUp).Offset(1, 0)
'write the values from source into destination
rDest.Resize(5, 1).Value = wbSource.Sheets(1).Range("C7:D33").Value
wbSource.Close False
Next i
End Sub
The below should achieve what you're after.
Option Explicit
Sub copy_rng()
Dim wb As Workbook, wbDest As Workbook, ws As Worksheet, wsDest As Worksheet, wsSrc As Worksheet
Dim wbNames() As Variant
Dim destFirstCell As Range
Dim destColStart As Integer, destRowStart As Long, i As Byte
Dim destPath As String
Set wb = ThisWorkbook
Set ws = wb.Sheets("Sheet1") ' Amend to your sheet name
Set wsSrc = wb.Sheets("Sheet2") ' Amend to sheet name with table data
wbNames = ws.Range("A2:A" & lrow(1, ws)) ' Pass col number into lrow function
destPath = "C:\Users\"
Application.ScreenUpdating = False
For i = 1 To UBound(wbNames, 1)
Set wbDest = Workbooks.Open(destPath & wbNames(i, 1))
Set wsDest = wbDest.Worksheets(1)
With wsDest
Set destFirstCell = .Cells.Find(What:="*")
destColStart = destFirstCell.Column
destRowStart = destFirstCell.Row
.Range(Cells(destRowStart, destColStart), _
Cells(lrow(destColStart, wsDest), icol(destRowStart, wsDest))).Copy
End With
wsSrc.Cells(lrow(1, wsSrc) + 1, 1).PasteSpecial Paste:=xlPasteAll
wbDest.Close False
Next i
Application.ScreenUpdating = True
End Sub
Function lrow(ByVal col_num As Integer, sheet_name As Worksheet) As Long
lrow = sheet_name.Cells(Rows.Count, col_num).End(xlUp).Row
End Function
Function icol(ByVal row_num As Long, sheet_name As Worksheet) As Integer
icol = sheet_name.Cells(row_num, Columns.Count).End(xlToLeft).Column
End Function
Ensure you copy both of the functions across, they're used to create the dimensions of the table, and then copying the table.
You will need to amend the sheet name variables. Let me know if you have any questions.
You need to amend the range of where the workbook names are stored. You need to pass the column number in, so that the last row can be calculated. You can also amend the column in which data is pasted back into the workbook.
With the help of this code you can copy all workbooks and worksheets data
into one workbook
Sub copydata()
Dim fso As Scripting.FileSystemObject
Dim fill As Scripting.File
Dim oldfolder As String
Dim newfolder As String
Dim subfolder As Folder
Dim myfolder As Folder
Dim fd As FileDialog
Dim loopcount As Integer
Dim wb
Dim wb2 As Workbook
Dim rr As Range
Set fso = New Scripting.FileSystemObject
Set wb = ThisWorkbook
Set fd = Application.FileDialog(msoFileDialogFolderPicker)
fd.Title = "Please Select Folder to copy"
fd.ButtonName = "Go!"
fd.Show
oldfolder = fd.SelectedItems(1)
Set myfolder = fso.GetFolder(oldfolder)
'Application.ScreenUpdating = False
Application.EnableEvents = False
For Each subfolder In myfolder.SubFolders
For Each fill In subfolder.Files
If fill Like "*.xlsm" Or fill Like "*.xlsx" Or fill Like ".*xls" Then
'fill.Range("A1:Z100").Copy
Set wb2 = Application.Workbooks.Open(fill,0 , True)
wb2.Activate
For loopcount = 1 To wb2.Worksheets.Count
wb2.Activate
Worksheets(loopcount).Activate
Range("A1:Z300").Copy 'Replace your range
wb.Activate
Sheet1.Activate
Set rr = Range("A:A").Find("", Range("A1"))
rr.Select
ActiveSheet.Paste
ActiveCell.Offset(1, 0).Select
Next loopcount
wb2.Close False
End If
Application.CutCopyMode = False
Debug.Print fill.Name
Next fill
Next subfolder
MsgBox "Done"
For Each fill In myfolder.Files
Application.DisplayAlerts = False
If fill Like "*.xlsm" Or fill Like "*.xlsx" Or fill Like ".*xls" Or fill Like "*.xlsb" Then
'fill.Range("A1:Z100").Copy
Set wb2 = Application.Workbooks.Open(fill, 0, True)
wb2.Activate
For loopcount = 1 To wb2.Worksheets.Count
wb2.Activate
Worksheets(loopcount).Activate
Range("A:Z").EntireColumn.Hidden = False
Range("A1:Z1").AutoFilter
Range("A1:Z300").Copy
wb.Activate
Sheet1.Activate
Set rr = Range("A:A").Find("", Range("A1"))
rr.Select
ActiveSheet.Paste
ActiveCell.Offset(1, 0).Select
Next loopcount
wb2.Close False
End If
Application.CutCopyMode = False
Debug.Print fill.Name
Next fill
Application.EnableEvents = True
End Sub