Sub VBA_Read_External_Workbook()
'''''Define Object for Target Workbook
Dim Target_Workbook As Workbook
Dim Source_Workbook As Workbook
Dim Target_Path As String
'''''Assign the Workbook File Name along with its Path
'''''Change path of the Target File name
Target_Path = "C:\Users\User\Desktop\Excel VBA\Working Sample Folder\MAY 2017 Summary- Atlas work.xlsx"
Set Target_Workbook = Workbooks.Open(Target_Path)
Set Source_Workbook = ThisWorkbook
'''''With Target_Workbook object now, it is possible to pull any data from it
'''''Read Data from Target File
Target_Data = Target_Workbook.Sheets(1).Range("A1:B3")
Source_Workbook.Sheets(2).Range("A1:B3") = Target_Data
'''''Update Target File
Source_data = Source_Workbook.Sheets(1).Range("A1:B3")
Target_Workbook.Sheets(1).Range("A1:B3") = Source_data
'''''Close Target Workbook
Source_Workbook.Save
Target_Workbook.Save
Target_Workbook.Close False
'''''Process Completed
MsgBox "Task Completed"
End Sub
I've been modifying this code that i found in this website to use it for copying the specific data in a specific format.
What I need some guidance is to add a loop to get the data from the files that will be put in a folder.Files that needed to be read
So my questions
Basically, I already set the specific range of data that needed to be copied and paste on my destination files. But instead of keep changing the target path, is there a way to put a loop that it will auto jump to the next workbook and get those values?
I found out that using this method to transfer the data, it doesn't transfer the data nature which for example if it is in time format at the source file, when the VBA execute and update the destination file, the value is not in the same format and all are pasted in general format.
Is it possible to loop the update where it will auto jump to the next row to paste the data?
I tried to google some of the VBA codes but the answer is very vague.
Appreciate any input from your experiences.
1)Basically, I already set the specific range of data that needed to be copied and paste on my destination files. But instead of keep changing the target path, is there a way to put a loop that it will auto jump to the next workbook and get those values?
This will get you started
Dim MyFolder As String
Dim StrFile As String
Dim flName As String
'~~> Change this to the relevant folder
MyFolder = "c:\MyFolder\"
StrFile = Dir(MyFolder & "*.xls*")
'~~> Loop through all excel files in the folder
Do While Len(StrFile) > 0
flName = MyFolder & StrFile
'~~> Open the workbook
Set wb = Workbooks.Open(flName)
'
'~~> Rest of your code
'
wb.Close (False)
StrFile = Dir
Loop
2)I found out that using this method to transfer the data, it doesn't transfer the data nature which for example if it is in time format at the source file, when the VBA execute and update the destination file, the value is not in the same format and all are pasted in general format.
The code is directly setting the value and hence the formats are not copied. You need to .Copy and .Pastespecial instead of directly setting the value. Record a macro to see how .Copy and .Pastespecial work. or read up on
Range.PasteSpecial Method (Excel)
3)Is it possible to loop the update where it will auto jump to the next row to paste the data?
Find the last row and then do a copy paste to that row. Please see the below link to find the last row.
Finding Last Row
Related
I am trying to combine a table from multiple workbooks and create a new master workbook which contains all the extracted tables. My current code successfully copies and pastes data from each workbook but still have a few issues and couldn't figure them out by myself.
First, I want to skip the first row, which is just variable names, starting from the second source file. I still need it from the first source file so that my master workbook can have column names in the first row. I tried to achieve this using some loops but it didn't work. Which part do I need to update in order to do this?
Second, is there a way to create an additional column in the master workbook as a flag that shows the source file of data when I copy and paste a table from each individual source file to the master?
For example, if a source excel file is named "file123", the flag column would contain "file123" as its value.
Lastly, in the line of my code where it pastes the copied value,
MaWS.Range("A12785").End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues
I randomly assigned a big number "A12785" but how do I determine this value? Can I just keep it random?
FYI, here is my current code.
My master workbook is named "Master" and has a sheet named "Summary"
My source files have the table in the "data" tab.
Option Explicit
Sub Merge()
Dim SrPath As String
Dim MaPath As String
Dim SrName As String
Dim MaName As String
Dim SrTemplate As String
Dim MaTemplate As String
Dim SrWS As Worksheet
Dim MaWS As Worksheet
'Define folders and filenames
SrPath = "C:\Users\Documents\Test\"
MaPath = "C:\Users\Documents\Test\Master\"
SrTemplate = "*.xlsx" '
MaTemplate = "Master.xlsm"
'Open the template file and get the Worksheet to put the data into
MaName = Dir(MaPath & MaTemplate)
Workbooks.Open SumPath & SumName
Set MaWS = ActiveWorkbook.Worksheets("Summary")
'Open each source file, copying the data from each into the template file
SrName = Dir(SrPath & SrTemplate) 'Retrieve the first file
Do While SrName <> ""
'Open the source file and get the worksheet with the data we want.
Workbooks.Open SrPath & SrName
Set SrWS = ActiveWorkbook.Worksheets("data")
'Copy the data from the source and paste at the end of Summary sheet
SrWS.Range("A1:N35").Copy
sumWS.Range("A12785").End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues
'Close the current sourcefile and get the next
Workbooks(SrName).Close SaveChanges:=False 'close
MyName = Dir 'Get next file
Loop
'Now all sourcefiles are copied into the Template file. Close and save it
Workbooks(MaName).Close SaveChanges:=True
End Sub
Thank you.
I am trying to consolidate a specific range of date from many csv files. What I want to do is to select this range and paste it into a master sheet in a separate workbook. The .csv files are all arranged in one folder and all have 1 sheet in the same format. The range can be dynamic so this code will need to be able to select all the rows below a cell or be able to delete blank rows from a larger range. I would appreciate any help.
Thanks
I've used a batch file to something like this in the past. This code does not handle deleting Aggregate.csv if the batch file is ran again.
#ECHO OFF
Set loc=C:\Test\
Copy %loc%*.csv %loc%\Aggregate.csv
Once in Excel, you can delete all the header rows and filter date ranges with VBA. You can also use VBA's Shell method to aggregate with Copy.
Edit:
You can also create a data source in Other Data Sources > MS Query in order to query Aggregate.csv with Microsoft Text Driver using date ranges, etc.
Some pointers how to go about the solution:
First, enumerate the files using the FileSystemObject.
Set fso = CreateObject("Scripting.FileSystemObject")
set fld = fso.GetFolder("path\to\my\folder")
For Each file in fld.Files
If file.Name Like "*.csv" Then LoadFile file.Name
Next
Declare fso, fld, file as Object. LoadFile will be a function you have to write, which processes a single file. It will look approximately like this:
Sub LoadFile(filename as String)
dim buffer() as variant
dim wb as workbook, ws as worksheet
dim i as Long, beginrow as long, endrow as long
Set wb = Workbooks.Open(filename)
Set ws = wb.Worksheets(1) ' .csv always has 1 worksheet
buffer = ws.Range("A1:A10000") ' put a sensible upper bound here
for i = 1 to 10000
' replace (..first..) and (..last..) with your search interval
if buffer(i, 1) <= (..first..) Then beginrow = i
if buffer(i, 1) < (..last..) Then endrow=i
next
' now beginrow and endrow hold the interval to cut
ws.Cells(beginrow, 1).Resize(endrow-beginrow+1, column_count).Copy destination:=(... to be determined ..)
wb.Close
End Sub
The function opens the file; then searches the first column for the interval to copy; then copies the cells and closes the file.
The code is not runnable as-is, but should hopefully give you the right ideas.
I have a workbook containing one worksheet ("DB Output" or Sheet 34) which I would like to copy to several (around 45) files in within the same folder.
None of the target files have an existing sheet named "DB Output" - the objective is to find a way to insert a copy of this sheet, forumlas and all, into each one.
The range of cells on that sheet that needs to be copied to a sheet of the same name in each book is A1:PE5
The sheet contains references to cells in the book it is currently in, however as the files which I am seeking to copy the worksheet to all share the same template, I want the references to be to the local file, not the original one.
I've tried looking at RDBMerge, however it seems that is for merging sheets, and while I do want to do that, it will not help me do it multiple times quickly.
Likewise I have looked on SO for similar situations, this is the closest, however my attempts to adapt that code have failed as I only have a single workskeet. Never the less, as it is always useful to inlcude what you have already tried, here is my existing attempt:
Option Explicit
Public Sub splitsheets()
Dim srcwb As Workbook, trgwb As Workbook
Dim ws As Worksheet, t1ws As Worksheet
Dim rng1 As Range
Dim trgnm As String
Dim fpath As String
Application.ScreenUpdating = False
'--> Set this to the location of the target workbooks
fpath = "C:/file/path/"
Set srcwb = ThisWorkbook
For Each ws In srcwb.Worksheets
trgnm = ws.Name
'--> Change A1:B3 to the range to be copied to inside page
Set rng1 = srcwb.Sheets(trgnm).Range("A1:PE5")
Set trgwb = Workbooks.Open(fpath & trgnm & ".xlsm")
With trgwb
Set t1ws = .Sheets("DB Output")
End With
'--> Change A1:B3 to the range where you want to paste
rng1.Copy t1ws.Range("A1:PE5")
trgwb.Close True
Next
Application.ScreenUpdating = True
End Sub
However this starts with the first sheet in the workbook that contains DB Output (the sheet to be copied) and gives an error that "NameOfSheet1.xlsm" does not exist in that directory (which it does not).
Any help is much appreciated.
This should copy from the active workbook to all files in a directory. If you need help modifying it to fit your specific use let me know!
Edit: fixed code to only copy A1:PE5 and save each workbook.
Sub Example()
Dim path As String
Dim file As String
Dim wkbk As Workbook
path = "C:\Test\"
file = Dir(path)
Application.DisplayAlerts = False
Do While Not file = ""
Workbooks.Open (path & file)
Set wkbk = ActiveWorkbook
Sheets.Add After:=Sheets(Sheets.Count)
ActiveSheet.Name = "DB Output"
ThisWorkbook.Sheets("DB Output").Range("A1:PE5").Copy Destination:=wkbk.Sheets("DB Output").Range("A1")
wkbk.Save
wkbk.Close
file = Dir
Loop
Application.DisplayAlerts = True
End Sub
Please note that I did not add error handling so this could break if the active workbook is included in the directory you are trying to copy or if a sheet with the same name already exists in the workbook. If this is an issue let me know and I will add error handling.
A non-IT related class has been assigned a group project where the work they do will be stored is a single .xlsx file. The members decided the best way to collaboratively edit said file would be to split it into its constituent sheets, upload each *.xlsx sheet to an SVN repository, and use locks and a .txt file to organize sheet/member responsibility.
The group has accomplished the splitting of said files with a VB script (courtesy of this wonderful site) which was as follows:
Sub SaveSheets()
Dim strPath As String
Dim ws As Worksheet
Application.ScreenUpdating = False
strPath = ActiveWorkbook.Path & "\"
For Each ws In ThisWorkbook.Sheets
ws.Copy
'Use this line if you want to break any links:
BreakLinks Workbooks(Workbooks.Count)
Workbooks(Workbooks.Count).Close True, strPath & ws.Name & ".xlsx"
Next
Application.ScreenUpdating = True
End Sub
Sub BreakLinks(wb As Workbook)
Dim lnk As Variant
For Each lnk In wb.LinkSources(xlExcelLinks)
wb.Breaklink lnk, xlLinkTypeExcelLinks
Next
End Sub
Therewith the group now has a repository where each member is currently in the process of editing their respective files. The question then is, how can we automate the re-unification of these files into one .xlsx file with the preservation of the original links.
EDIT 4/2: started bounty // I'm aware that the links were "broken" by the above script but am not exactly sure what this means though I suspect it would make re-assembly with the preservation of original links more difficult. It should be noted that the original file which had the links is still available and might could be used to assist with this problem.
EDIT 4/2: Excel version is 2010--original links do not exist in current files.
EDIT 4/3: Original links are not in the current files, but it is desired that with the re-unification the original links (from original unedited file, pre-splitting) be re-created/preserved.
If you have SharePoint, you can all update the same Excel (2003 or 2010) book.
http://office.microsoft.com/en-us/excel-help/about-shared-workbooks-HP005262294.aspx
The links then don't really apply in the solution, as you said the original doesn't have any links and so reassembly with links isn't required.
The script provided even has a comment embedded saying "Use this line if you want to break any links:". So if you comment the line below out (prepend the line with a ') it will preserve the links in the child workbooks.
Using the answer to a previous question on copying sheets to another workbook reassembly can be accomplished with the following VBA:
Sub CombineSheets()
Dim strPath As String
Dim ws As Worksheet
Dim targetWorkbook As Workbook
Set targetWorkbook = ActiveWorkbook
Application.ScreenUpdating = False
'Adjust path location of split files
strPath = "C:\code\xls-split"
Dim str As String
'This can be adjusted to suit a filename pattern.
str = Dir(strPath & "\*.xl*")
Do Until str = ""
'Open Workbook x and Set a Workbook variable to it
Set wbResults = Workbooks.Open(strPath & "\" & str, UpdateLinks:=0)
For Each Sheet In ActiveWorkbook.Sheets
Sheet.Copy After:=targetWorkbook.Sheets(targetWorkbook.Sheets.Count)
Next Sheet
wbResults.Close SaveChanges:=False
str = Dir()
Loop
Application.ScreenUpdating = True
End Sub
This will append the other workbooks to the currently opened workbook.
Sourced Replacing FileSearch function for code to find xls files in a directory.
We probably need more detail in order to help you, but you may be able to accomplish what you need as follows (maybe this can kick-start a solution):
Loop through the sheets in the workbook
For each sheet
Open the appropriate xlsx file
Identify non-formula cells
For each of those cells
Copy to the identical location in the main workbook
Close the xlsx file
Below is an example (based on your SaveSheets code). If you try this, be sure to backup everything first. We obviously don’t know how the spreadsheets are laid out and how they are used. It would really suck if it got all screwed up. Also, there are some assumptions:
The layout and used range in the xlsx files are the exact same layout and used range as it appears in the original workbook.
The links you are referring to are formulas (either to another sheet or another workbook).
If these assumptions are wrong, you will need to modify as appropriate (identifying specific ranges to copy and/or adding more robust logic to the routine).
Note that the actual code to do this is very short. I added comments and basic error handling which significantly increased the amount of code.
This code would be added to the original workbook.
Sub RetrieveSheets()
Dim strPath As String
Dim ws As Worksheet
Dim ws2 As Worksheet
Dim wbk As Workbook
Dim rng As Range
Application.ScreenUpdating = False
strPath = ActiveWorkbook.Path & "\"
For Each ws In ThisWorkbook.Sheets
'Open the xlsx file (read only)
Set wbk = Nothing
On Error Resume Next
Set wbk = Workbooks.Open(strPath & ws.Name & ".xlsx", ReadOnly:=True)
On Error GoTo 0
'Continue if xlsx file was successfully opened
If Not wbk Is Nothing Then
Set ws2 = Nothing
On Error Resume Next
Set ws2 = wbk.Worksheets(ws.Name)
On Error GoTo 0
'Continue if appropriate sheet was found
If Not ws2 Is Nothing Then
'Identify cells to copy over (cells that are constants)
For Each rng In ws2.Cells.SpecialCells(xlCellTypeConstants)
'set the cell value equal to the identical cell location in the xlsx file
If (Left(ws.Range(rng.Address).Formula, 1)) <> "=" Then
ws.Range(rng.Address) = rng
End If
Next
Set ws2 = Nothing
End If
'Close the xlsx file
wbk.Close False
End If
Next
Set wbk = Nothing
Application.ScreenUpdating = True
End Sub
This is a rough outline of how I accomplished this:
Use Office2013 and not office 2010
create tmp/ directory with original .xlsx assignment file.
create source/ directory in tmp/
use split sheets module (listed on this page), but comment out the line that break links.
place all of the resulting .xlsx files into source/ (you can delete the original .xlsx file)
remote the first sheet from the sources/ folder, and place it ../
Open this first sheet, and import/use the 'combinesheets' module listed on this page.
Save the sheet, reopen it and you'll be prompted to update links. Do so, and select "change source" and select the first sheet Re in step 6.
links will automatically update; done.
Notes: you'll have to save a file as macro enabled, ...
Take a look at this MSDN Article on Merging Data from multiple workbook (.xls/.xlsx) files
http://msdn.microsoft.com/en-us/library/office/gg549168%28v=office.14%29.aspx
I don't know much about VBA but I think this is what you are looking for.
Also note it does get rid of the need for a text file to manage the files
Here is what I am trying to do. I am trying to create a workbook based on a template named by the title and to create a workbook for each row. And for the macro to loop until all rows have been depleted.
The deliverables that I want at the end are 3 excel documents named (Alpha.xlsx, Beta.xlsx, Gamma.xlsx) with the corresponding values from access plugged into their corresponding cells in their corresponding workbook. The subsequent math is there because I need to be able to manipulate the values once they are in excel.
Here is some of the research that I've found that I haven't quite been able to make much sense of due to my lack of experience coding in vba.
Links
(I can't post more than 2 so I'll keep the number of articles terse):
Research: databasejournal.com/features/msaccess/article.php/3563671/Export-Data-To-Excel.htm
Example Database/Spreadsheet:
http://www.sendspace.com/file/iy62c0
Image Album (has a picture of the database and the template in case you don't want to download):
http://imgur.com/pytPK,PY8FP#0
Any help will be much appreciated! I've been reading up and trying to figure out how to get this to work #.#
This isn't complete, but should help you get started...
Option Compare Database
Option Explicit
'Enter Location of your Template Here
Const ExcelTemplate = "C:\MyTemplate.xltx"
'Enter the Folder Directory to save results to
Const SaveResutsFldr = "C:\Results\"
Sub CreateWorkbook()
Dim SaveAsStr As String
Dim ExcelApp, WB As Object
'Create Reference to Run Excel
Set ExcelApp = CreateObject("Excel.Application")
'Create Reference to your Table
Dim T As Recordset
Set T = CurrentDb.OpenRecordset("tblData")
'Loop through all Record on Table
While Not T.BOF And T.EOF
'Open Your Excel Template
Set WB = ExcelApp.Workbooks.Open(ExcelTemplate)
'Enter your data from your table here to the required cells
WB.Worksheets("NameOfYourWorkSheet").Range("A1") = T("numValue1")
'Repeat this line for each piece of data you need entered
'Changing the Sheet name, cell range, a field name as per your requirements
'WB.Wor...
'WB.Wor...
'Save and Close the Workbook
SaveAsStr = SaveResutsFldr & T("Title") & ".xlsx"
WB.SaveAs SaveAsStr
WB.Close
Set WB = Nothing
'Move to the Next Record
T.MoveNext
Wend
'Close down the Excel Application
ExcelApp.Quit
Set ExcelApp = Nothing
End Sub