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
Related
I have an excel worksheet that accepts input from another excel file. This excel file has structured data in which I need to separate individually as sheets. I already have the following code to copy and format that data in a certain range but I need to loop this process for the whole worksheet until there's no more data.
The range currently I set is A2:P20 the next range is 4 rows below and that would be A25:P43.
Option Explicit
Public Sub CopySheetToClosedWorkbook()
Dim fileName
Dim closedBook As Workbook
Dim currentSheet As Worksheet
fileName = Application.GetOpenFilename("Excel Files (*.xls*),*xls*")
If fileName <> False Then
Application.ScreenUpdating = False
Set currentSheet = Application.ActiveSheet
Set closedBook = Workbooks.Open(fileName)
closedBook.Sheets(1).Range("A2:P20").Copy
ThisWorkbook.Worksheets("input").Range("A2").PasteSpecial xlPasteValues
closedBook.Application.CutCopyMode = False
closedBook.Close (True)
Application.ScreenUpdating = True
CopySheetAndRenameByCell2
End If
End Sub
You could do something based on the code below. I have set the last row as 1000, you will need to derrive this from your data.
Sub SplitRangeTest()
Dim lLastRow As Long
Dim lRow As Long
Dim lRangeSize As Long
Dim lSpacerSize As Long
lRangeSize = 19
lRow = 2
lSpacerSize = 4
lLastRow = 1000 ' Get the last populated row in the column of choice here
Do Until lRow > lLastRow
Debug.Print Range("A" & lRow).Resize(lRangeSize, 16).Address
lRow = lRow + lRangeSize + lSpacerSize
Loop
End Sub
Try this:
Public Sub CopySheetToClosedWorkbook()
Dim fileName As String
Dim closedBook As Workbook
Dim currentSheet As Worksheet
fileName = Application.GetOpenFilename("Excel Files (*.xls*),*xls*")
If fileName <> False Then
start_row = 2
rows_to_copy = 19
row_step = 23
Set currentSheet = Application.ActiveSheet
Set closedBook = Workbooks.Open(fileName)
last_row = Sheets(1).Cells(Sheets(1).Rows.Count, "A").End(xlUp).Row
Application.ScreenUpdating = False
For y = start_row To last_row Step row_step
ThisWorkbook.Worksheets("input").Rows(y).Resize(rows_to_copy, 16).Value = closedBook.Sheets(1).Rows(y).Resize(rows_to_copy, 16).Value
Next
Application.ScreenUpdating = True
End If
End Sub
it's worth mentioning here that you set currentSheet but don't actually use it. Also, you shouldn't really use ThisWorkbook like that. Maybe you should be using currentSheet instead (or at least, it's parent).
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
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
The code below copies all worksheet contents from source workbook into destination workbook. Worksheet names are exactly same. The code copies the data from source in exactly the same order/range ("A2:A700," & _ "D2:D700," & _"C2:C700") into destination workbook. However, I want the data from source in the range above to go into a different range(I3,k3 and AC3) on the destination workbook. Any assistance is appreciated.
Option Explicit
Sub seunweb()
'this macro copies from one workbook to another
Dim wbSource As Workbook, wbDestination As Workbook
Dim ws As Worksheet, rng As Range
Dim NextRow As Long, LastRow As Long
Application.ScreenUpdating = False
Set wbSource = Workbooks.Open("D:\test.xls")
Set wbDestination = ThisWorkbook
For Each ws In wbSource.Sheets
For Each rng In ws.Range("A2:A700," & _
"D2:D700," & _
"C2:C700").Areas
wbDestination.Sheets(ws.Name).Range(rng.Address).Value = rng.Value
Next rng
Next ws
wbSource.Close SaveChanges:=False
Application.ScreenUpdating = True
End Sub
Instead of your for loop, use somthing like
Set rng = ws.Range("A2:A700")
wbDestination.Sheets(ws.Name).Range("I3").Resize(rng.Rows.Count, rng.Columns.Count).Value = rng.Value
Set rng = ws.Range("D2:D700")
wbDestination.Sheets(ws.Name).Range("K3").Resize(rng.Rows.Count, rng.Columns.Count).Value = rng.Value
' continue this this for each source range