I have a little problem with my code. I want to copy my data from one file to my main file. When I check the code I meet with one problem. The code works fine until copied. In this line
Set cell1 = wsDest.Cells(1, Range("B1").End(xlToRight).Column + 1)
the cell is selected from the file from I am taking the data and not the folder I am pasting into.
I want my data to paste from these other files into the main file. I want to add them as columns, not rows.
Sub MoveCopyRowsColumns()
Dim mainWb As Workbook
Dim newWb As Workbook
Dim mainWs As Worksheet
Dim newWs As Worksheet
Dim strFolder As String
Set mainWb = Workbooks("Main_file.xlsm")
Set mainWs = mainWb.Worksheets("Worksheet1")
mainWs.Cells(1, Range("B1").End(xlToRight).Column + 1).Select
mainWs.Columns(ActiveCell.Column).EntireColumn.Delete
strFolder = "C:\Users\User1\Desktop\Folder_with_files\"
strFile = Dir(strFolder & "*.xls*")
Do While strFile <> ""
Set newWb = Workbooks.Open(strFolder & strFile)
Set newWs = newWb.Sheets(1)
strFile = Dir
newWs.Cells(1, Range("B1").End(xlToRight).Column + 1).Select
newWs.Columns(ActiveCell.Column).EntireColumn.Delete
newWs.Range("B1", Range("B1").End(xlDown).End(xlToRight)).Copy _
mainWs.Range("P1")
Loop
End Sub
You have to declare which file/sheet is which. Each line should refer to the right worksheet. All lines starting with cell or range should have worksheet first like: "mainWs.Cell".
In the new file you have not declared any worksheet, only workbook (wb).
I haven't tryed the code below, but I hope it unlocks your problem thinking.
Good luck!
Sub MoveCopyRowsColumns()
Dim mainWb As Workbook
Dim newWb As Workbook
Dim mainWs As Worksheet
Dim newWs As Worksheet
Dim strFolder As String
Dim strFile As String
Dim cell1 As Range
Set mainWb = Workbooks("Main_file.xlsm")
Set mainWs = mainWb.Worksheets("Worksheet1")
mainWs.Cells(1, Range("B1").End(xlToRight).Column + 1).Select
mainWs.Columns(ActiveCell.Column).EntireColumn.Delete
'in my main file I delete the last column only one
strFolder = "C:\Users\User1\Desktop\Folder_with_files\"
strFile = Dir(strFolder & "*.xls*")
Do While strFile <> ""
Set newWb = Workbooks.Open(strFolder & strFile)
'Set the sheet you want to use, using "first sheet" or sheet by name
'Set newWs = newWb.Sheets(1)
'Set newWs = newWb.Worksheets("Worksheet1")
strFile = Dir
newWs.Cells(1, Range("B1").End(xlToRight).Column + 1).Select
newWs.Columns(ActiveCell.Column).EntireColumn.Delete
'Set cell1 = newWs.Cells(1, Range("B1").End(xlToRight).Column + 1)
newWs.Cells(1, Range("B1").End(xlToRight).Column + 1).Copy
'the adress is taking from file when I take the data, not the main file which should take.
mainWs.Range(cell1).PasteSpecial Paste:=xlPasteValues
Loop
End Sub
Related
I have multiple workbooks in a single folder. All the workbooks share the same format and I wish to copy from the same range on the first worksheet in all workbooks and add this to a single worksheet of a newly created workbook.
The code so far:
Sub OpenAllCompletedFilesDirectory()
Dim Folder As String, FileName As String
Folder = "pathway..."
FileName = Dir(Folder & "\*.xlsx")
Do
Dim currentWB As Workbook
Set currentWB = Workbooks.Open(Folder & "\" & FileName)
CopyDataToTotalsWorkbook currentWB
FileName = Dir
Loop Until FileName = ""
End Sub
Sub AddWorkbook()
Dim TotalsWorkbook As Workbook
Set TotalsWorkbook = Workbooks.Add
outWorkbook.Sheets("Sheet1").Name = "Totals"
outWorkbook.SaveAs FileName:="pathway..."
End Sub
Sub CopyDataToTotalsWorkbook(argWB As Workbook)
Dim wsDest As Worksheet
Dim lDestLastRow As Long
Dim TotalsBook As Workbook
Set TotalsBook = Workbooks.Open("pathway...")
Set wsDest = TotalsBook.Worksheets("Totals")
Application.DisplayAlerts = False
lDestLastRow = wsDest.Cells(wsDest.Rows.Count, "A").End(xlUp).Offset(1).Row
argWB.Worksheets("Weekly Totals").Range("A2:M6").Copy
wsDest.Range("A" & lDestLastRow).PasteSpecial
Application.DisplayAlerts = True
TotalsBook.Save
End Sub
This works - to a point. It does copy the correct ranges across and place the results one below another on the "Totals" worksheet of the "Totals" workbook, but it raises a 'Subscript out of range' error on:
argWB.Worksheets("Weekly Totals").Range("A2:M6").Copy
after data from the last workbook has been pasted.
How can I tidy this code so that it works without error?
I imagine there is scope to improve the code too.
I'd maybe do something like this.
Note you can just open the summary workbook once before looping over the files.
Sub SummarizeFiles()
'Use `Const` for fixed values
Const FPATH As String = "C:\Test\" 'for example
Const TOT_WB As String = "Totals.xlsx"
Const TOT_WS As String = "Totals"
Dim FileName As String, wbTot As Workbook, wsDest As Worksheet
'does the "totals" workbook exist?
'if not then create it, else open it
If Dir(FPATH & TOT_WB) = "" Then
Set wbTot = Workbooks.Add
wbTot.Sheets(1).Name = TOT_WS
wbTot.SaveAs FPATH & TOT_WB
Else
Set wbTot = Workbooks.Open(FPATH & TOT_WB)
End If
Set wsDest = wbTot.Worksheets(TOT_WS)
FileName = Dir(FPATH & "*.xlsx")
Do While Len(FileName) > 0
If FileName <> TOT_WB Then 'don't try to re-open the totals wb
With Workbooks.Open(FPATH & FileName)
.Worksheets("Weekly Totals").Range("A2:M6").Copy _
wsDest.Cells(wsDest.Rows.Count, "A").End(xlUp).Offset(1)
.Close False 'no changes
End With
End If
wbTot.Save
FileName = Dir 'next file
Loop
End Sub
I try to copy data from Workbooks with Sheets("daily shift report") to another Workbooks Sheets ("Sheet1") by transpose according to the code below.
Sub copyDatafrommultipleworkbookintomaster()
Dim FolderPath As String, Filepath As String, Filename As String, Erow As Range
FolderPath = "C:\Users\YIT\Documents\test\April57\"
Filepath = FolderPath & "*.xls*"
Filename = Dir(Filepath)
Do While Filename <> ""
Workbooks.Open (FolderPath & Filename)
ActiveWorkbook.Sheets("daily shift report").Range("B71:G77").Copy
Application.DisplayAlerts = False
ActiveWorkbook.Close
Worksheets("Sheet1").Range("A1").PasteSpecial Transpose:=True
Filename = Dir
Loop
End Sub
But found Run time error '1004' Application-defined or object-defined error.I guess error in line 14.
Worksheets("Sheet1").Range("A1").PasteSpecial Transpose:=True
Could you please suggest a solution to this problem?.
Try the next code, please. It will Paste, from each existing .xls workbook, in the next empty column of "Sheet1":
Sub copyDatafrommultipleworkbookintomaster()
Dim FolderPath As String, Filepath As String, Filename As String
Dim wb As Workbook, ws As Worksheet, Col As Long
Col = 1
Set ws = ActiveWorkbook.Sheets("Sheet1")
FolderPath = "C:\Users\YIT\Documents\test\April57\"
Filename = Dir(FolderPath & "*.xls*")
Do While Filename <> ""
Set wb = Workbooks.Open(FolderPath & Filename)
wb.Sheets("daily shift report").Range("B71:G77").Copy
ws.cells(1, Col).PasteSpecial Paste:=xlPasteAll, Transpose:=True
Col = Col + 7 'increment the next col where to paste
wb.Close False
Filename = Dir
Loop
End Sub
Please see if either of following two set of codes is useful to you.
Mention your Source File Path & File name directly as string
Sub GetData()
Dim customerFilename As String
Dim customerWorkbook As Workbook
Dim targetSheet As Worksheet, sourceSheet As Worksheet
'targetSheet is Activeworkbook wherein you would want to fetch the data
Set targetSheet = ActiveWorkbook.Worksheets("Sheet1")
'Mention Source-file path & file name between double quotes below
customerFilename = "C:\Users\YIT\Documents\test\April57\Your_File_Name_Here.xls"
Set customerWorkbook = Application.Workbooks.Open(customerFilename)
Set sourceSheet = customerWorkbook.Worksheets("daily shift report")
sourceSheet.Range("B71:G77").Copy
'select in which cell you want to paste data
targetSheet.Range("A1").PasteSpecial Transpose:=True
customerWorkbook.Close
End Sub
In this code you will be prompted to select Source File (.xls or .xlsx or .csv), no need to manually write Source Filepath & Filename.
Sub GetData2()
Dim filter As String, caption As String
Dim customerFilename As String
Dim customerWorkbook As Workbook
Dim targetSheet As Worksheet, sourceSheet As Worksheet
'targetSheet is Activeworkbook wherein you would want to fetch the data
Set targetSheet = ActiveWorkbook.Worksheets("Sheet1")
'Prompt to get the customerWorkbook i.e. Source Workbook
filter = "Excel and CSV Files (*.xls;*.xlsx;*.csv),*.xls;*.xlsx;*.csv"
caption = "Please Select an input file "
customerFilename = Application.GetOpenFilename(filter, , caption)
Set customerWorkbook = Application.Workbooks.Open(customerFilename)
Set sourceSheet = customerWorkbook.Worksheets("daily shift report")
sourceSheet.Range("B71:G77").Copy
'select in which cell you want to paste data
targetSheet.Range("A1").PasteSpecial Transpose:=True
customerWorkbook.Close
End Sub
Hope these codes are useful to you. Regards.
I've got a loop that will take contents from 3 worksheets in a folder, and paste them onto a different workbook. I'd like to name them all a number. 1, 2, and 3 in the new workbook for use later while manipulating data.
I've tried naming a variable but I can't figure out how to have it increase by 1 each time.
Sub find()
Dim iIndex As Integer
Dim ws As Excel.Worksheet
Dim wb As Workbook
Dim strPath As String
Dim strFile As String
Dim i As Integer
i = 1
strPath = "P:\SD\SUPPORT\File Load\"
strFile = Dir(strPath & "*.xls")
Do While strFile <> ""
Set wb = Workbooks.Open(Filename:=strPath & strFile)
For iIndex = 1 To wb.Worksheets.Count
Set ws = wb.Worksheets(iIndex)
'Copy each worksheet into dual sub workbook
ActiveSheet.Copy After:=Workbooks("Dual Sub.xlsm").Sheets(4)
ActiveSheet.Name = i + 1
Next iIndex
strFile = Dir 'This moves the value of strFile to the next file.
Loop
End Sub
With this code it just names the first sheet '2', and gives an error that it cannot name multiple sheets the same thing. I'd like for each sheet to be named as 1, 2, and 3.
If I understood your logic, this should do the trick:
Option Explicit
Sub find()
Dim ws As Worksheet
Dim wb As Workbook
Dim Masterwb As Workbook
Set Masterwb = Workbooks("Dual Sub.xlsm")
Dim strPath As String
Dim strFile As String
strPath = "P:\SD\SUPPORT\File Load\"
strFile = Dir(strPath & "*.xls")
Dim i As Long
i = i + 1
Do While strFile <> ""
Set wb = Workbooks.Open(Filename:=strPath & strFile)
For Each ws In wb.Worksheets 'better to loop like this (you loop trhough every item in the workbooks.worksheets collection)
ws.Copy After:=Masterwb.Sheets(Masterwb.Sheets.Count) 'copy the worksheet on the new workbook to the last index on the master workbook
Masterwb.Sheets(Masterwb.Sheets.Count).Name = i 'name the last sheet on the master workbook the value of i starting from 1
i = i + 1
Next ws
strFile = Dir 'This moves the value of strFile to the next file.
Loop
End Sub
The error occurs on the Open.Workbooks MasterFile line. I get the error of "This file cannot be found. Has it been removed, renamed, or replaced?" I used the fso.FileExist function to make sure the file does actually exist, and when I debug.print, the file name is exactly as it is specified in the variable MasterFile. Why won't VBA recognize this .xlsm file?
Sub ProcessData()
Dim fso As Scripting.FileSystemObject
Set fso = New Scripting.FileSystemObject
Dim fil As Scripting.File
Dim MyDir As String
Dim FolderSource As Scripting.Folder
'FolderSource is the fso enabled directory folder
Dim FolderDataSource As Scripting.Folder
'FolderDest is the fso enabled folder where the MasterFile is located
MyDir = "C:\Users..."
'MyDir is where all part number files will be stored
Dim MasterFile As String
Dim MasterFilePath As String
MasterFilePath = "C:\Users..."
MasterFile = "Function Master File.xlsm"
Dim wbSource As Workbook, wsSource As Worksheet
'The workbook and worksheet source will be the Master FIle
Dim wbDest As Workbook, wsDest As Worksheet
'The destination workbook and worksheet corresponding to the part number file
Dim myArray As Variant
Dim myTable As ListObject
Dim x As Long
myArray = Range("D13:D17")
'Array will draw from part number values that are entered in the appropriate area on the template
'Creating files for all new part numbers
Set FolderSource = fso.GetFolder(MyDir)
'For Each fil In FolderSource.Files
For x = LBound(myArray) To UBound(myArray)
If myArray(x, 1) <> "" Then
PartNumFile = MyDir & "\" & myArray(x, 1) & ".xlsx"
If Not fso.FileExists(PartNumFile) Then
Set newbook = Workbooks.Add
With newbook
.SaveAs Filename:=PartNumFile
End With
End If
End If
'Searching for the Part Number Data in the Master File
Set FolderDataSource = fso.GetFolder(MasterFilePath)
For Each fil In FolderDataSource.Files
Debug.Print fil.Name
If fso.FileExists(MasterFilePath & "\" & MasterFile) Then
Debug.Print fil.Name
Workbooks.Open MasterFile
Set wbSource = Workbooks(MasterFile)
Set wsSource = wbSource.Worksheets(1)
lrSource = wsSource.Range("A" & wsSource.Rows.Count).End(xlUp).Row
Set wbDest = Workbooks(myArray(x, 1) & ".xlsx")
Set wsDest = wbDest.Worksheets(1)
lrDest = wsDest.Range("A" & wsDest.Rows.Count).End(xlUp).Row + 1
wsSource.Range("A2:V" & lrSource).Copy Destination:=wsDest.Range("A" & lrDest)
End If
Next
Next
End Sub
i am trying to replace the current data in my file with the data in any another selected file which have same attributes. i want to replace the data from A1:Q in the current file from any other selected file. I tried writing the code but its showing errors .
Sub newdata()
Set appxl = CreateObject("Excel.application")
Dim myfile As Window
Dim currentSheet As Worksheet
Dim lastRow As Double
Dim sourceFileName As String
'Open Source File.xlsx
With appxl
vFile = Application.GetOpenFilename(Title:="Select File To Be Opened")
If vFile = False Then Exit Sub 'if the user didn't select a file, exit sub
' Set myfile = Workbooks.Open(vFile)
.Visible = False
End With
'Get first sheet data
Set myfile = appxl.Windows(vFile)
myfile.Activate
Set currentSheet = myfile.Sheets(1)
'Past the table in my current Excel file
lastRow = currentSheet.Range("A1").End(xlDown).Row
Sheets("Data retrieval").Range("A1:E" & lastRow) = currentSheet.Range("A1:Q" & lastRow).Value
'Close Source File.xlsx
appxl.Workbooks(vFile).Close
End Sub
This is not the prettiest of codes but it works just as you asked!
Sub newdata()
Dim myfile As Window
Dim currentSheet As Worksheet
Dim lastRow As Double
Dim sourceFileName As String
Dim sourcefileworksheet As String
Dim destinationwb As String
Dim destinationwksheet As String
'set destination worksheet as open workbook when you run macro
destinationwb = ActiveWorkbook.Name
destinationwksheet = ActiveSheet.Name
'Select source file
Dim fNameAndPath As Variant, wb As Workbook
fNameAndPath = Application.GetOpenFilename(Title:="Select File To Be Opened")
' cancel macro if nothing selected
If fNameAndPath = False Then
MsgBox ("Nothing Selected, Macro Cancelled")
Exit Sub
End If
'Open Source File.xlsx
Workbooks.Open (fNameAndPath)
'set source names
sourceFileName = ActiveWorkbook.Name
sourcefileworksheet = ActiveSheet.Name
'Determine last row of source
lastRow = Workbooks(sourceFileName).Worksheets(sourcefileworksheet).Range("A1").End(xlDown).Row
'Past the table in my current Excel file - Note that you should change the range of destination to A1:Q if you want all copied
Workbooks(destinationwb).Worksheets(destinationwksheet).Range("A1:E" & lastRow) = Workbooks(sourceFileName).Worksheets(sourcefileworksheet).Range("A1:Q" & lastRow).Value
'Close Source File.xlsx
Workbooks(sourceFileName).Close
'Confirm complete
MsgBox ("Complete!")
End Sub