I am trying to link two files: one is the raw data file and the other is the master database with calculation that we maintain. We get raw data each new months, and we want to automate the process of saving the raw data into the database using a macro. However, I would like to link the two file without opening the raw data and running it into background.
I have tried the following:
Sub CopyDataNewMonth()
Dim filepath As String
Dim filemonth As String
Dim filename As String
Dim fileactive As String
Dim filemaster As String
Dim xlApp As New Excel.Application 'New Excel Application
Dim xlWB As Excel.Workbook 'Workbook Object
Dim ListSheet(1 To 15) As Variant
Dim i As Integer
ListSheet(1) = "Total Sales"
ListSheet(2) = "Total Volumes"
ListSheet(3) = "Hard Seltzer Sales"
ListSheet(4) = "Hard Seltzer Volumes"
xlApp.Visible = False 'Hide Application
filemaster = "Y:\Master Folder\Master.xlsm"
filepath = "Y:\Raw Data Folder\" 'the path of the file
Workbooks("Master.xlsm").Activate 'the folder where we save the file
Sheets("Control").Activate
filemonth = Range("B3").Value
For i = 1 To 4
Sheets(ListSheet(i)).Activate
filename = Range("B1").Value 'the name of the file
fileactive = filepath & filemonth & filename 'file path complete
Set xlWB = xlApp.Workbooks.Open(fileactive) 'Open File in new App
If ListSheet(i) = "Total Sales" Or ListSheet(i) = "Hard Seltzer Sales" Then
xlWB.Sheets("$").Range("A7:XCF1000").Copy
Workbooks("Master.xlsm").Activate
Sheets(ListSheet(i)).Activate
Range("B3").Select
ActiveSheet.Paste
Else
xlWB.Sheets("$").Range("A7:XCF1000").Copy
Workbooks("Master.xlsm").Activate
Sheets(ListSheet(i)).Activate
Range("B3").Select
ActiveSheet.Paste
End If
xlWB.Close
Next
End Sub
However, I am encountering some problems as Excel tells me that it is still waiting for OLE to conclude the task. I guess that once I open the file in background it stays open and does not close. Additionally, I would like that once the raw data file closes, I do not have to manually select Don't Save.
Thanks for your ideas!
Related
I've got a folder which contains .txt files (they contain PHI, so I can't upload the .txt file, or an example without PHI, or even any images of it). I need an excel macro, which will allow the user to choose the folder containing the file, and will then insert the .txt file data into a new excel workbook, format the rows and columns appropriately, and finally save the file to the same folder that the source was found in.
So far I've got all of that working except for the formatting of rows and columns. As of now, the .txt data is inserted to a new workbook & worksheet, but I can't seem to figure out how to get rid of rows I don't need, or how to get the columns formatted appropriately.
Again, I can't upload the .txt file (or anything) because the Healthcare organization I work for blocks it - even if I've removed all PHI.
Below is the macro I've created so far:
Private Sub CommandButton2_Click()
On Error GoTo err
'Allow the user to choose the FOLDER where the TEXT file(s) are located
'The resulting EXCEL file will be saved in the same location
Dim FldrPath As String
Dim fldr As FileDialog
Dim fldrChosen As Integer
Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
With fldr
.Title = "Select a Folder containing the Text File(s)"
.AllowMultiSelect = False
.InitialFileName = "\\FILELOCATION"
fldrChosen = .Show
If fldrChosen <> -1 Then
MsgBox "You Chose to Cancel"
Else
FldrPath = .SelectedItems(1)
End If
End With
If FldrPath <> "" Then
'Make a new workbook
Dim newWorkbook As Workbook
Set newWorkbook = Workbooks.Add
'Make worksheet1 of new workbook active
newWorkbook.Worksheets(1).Activate
'Completed files are saved in the chosen source file folder
Dim CurrentFile As String: CurrentFile = Dir(FldrPath & "\" & "*.txt")
Dim strLine() As String
Dim LineIndex As Long
Application.ScreenUpdating = False
Application.DisplayAlerts = False
While CurrentFile <> vbNullString
'How many rows to place in Excel ABOVE the data we are inserting
LineIndex = 0
Close #1
Open FldrPath & "\" & CurrentFile For Input As #1
While Not EOF(1)
'Adds number of rows below the inserted row of data
LineIndex = LineIndex + 1
ReDim Preserve strLine(1 To LineIndex)
Line Input #1, strLine(LineIndex)
Wend
Close #1
With ActiveSheet.Range("A1").Resize(LineIndex, 1)
.Value = WorksheetFunction.Transpose(strLine)
.TextToColumns Other:=True, OtherChar:="|"
End With
ActiveSheet.UsedRange.EntireColumn.AutoFit
ActiveSheet.Name = Replace(CurrentFile, ".txt", "")
ActiveWorkbook.SaveAs FldrPath & "\" & Replace(CurrentFile, ".txt", ".xls"), xlNormal
ActiveWorkbook.Close
CurrentFile = Dir
Wend
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End If
Done:
Exit Sub
err:
MsgBox "The following ERROR Occurred:" & vbNewLine & err.Description
ActiveWorkbook.Close
End Sub
Any ideas of how I can delete entire lines from being brought into excel?
And how I can format the columns appropriately? So that I'm not getting 3 columns from the .txt file all jammed into 1 column in the resulting excel file?
Thanks
I'd recommend you not to re-invent the wheel. Microsoft provides an excellent add-on to accomplish this task, Power Query.
It lets you to load every file in a folder and process it in bulks.
Here you have a brief introduction of what can do for you.
I have a .bat file and I'm using it to execute a .vbs which I've pulled out of an excel workbook.
Currently, my .bat file looks like:
echo Starting program
start C:\Users\midi\Desktop\Refresh_Data_Connection.vbs
echo Finish program
However, the issue with my .vbs file is that it doesn't reference a specific workbook which I need it to. How could I set the .vbs to alter a specific workbook stored on my desktop? Any help/feedback or push in the right direction would be really helpful, thanks in advance!
My vbs is:
Sub RefreshConns()
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Sheets("Run Macro").Activate
Dim connName As String ' connection name
Dim connStr As String ' connection string
Dim sqltext ' SQL text
Dim TempconnName As String ' temporary connection name
Dim TempconnStr As String ' temporary connection string
Dim Tempsqltext ' temporary SQL text
Dim i As Integer
Dim SiteName As String
SiteName = ActiveSheet.Cells(1, 2)
'MsgBox (SiteName)
For i = 5 To 11
connName = ActiveSheet.Cells(i, 1).Value
connStr = ActiveSheet.Cells(i, 2).Value
sqltext = ActiveSheet.Cells(i, 4).Value
'MsgBox (connName)
TempconnStr = Replace(connStr, "SiteNameVBA", SiteName)
'Debug.Print (ActiveWorkbook.Connections(connName).ODBCConnection.Connection)
'MsgBox (TempconnStr)
'Tempsqltext = Replace(sqltext, "SiteNameVBA", SiteName)
'On Error Resume Next
ActiveWorkbook.Connections(connName).ODBCConnection.CommandText = sqltext
ActiveWorkbook.Connections(connName).ODBCConnection.Connection = "ODBC;" & TempconnStr
ActiveWorkbook.Connections(connName).Refresh
Next i
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub
Public Function ZeroToBlank(x As String) As String
If x = "0" Then
ZeroToBlank = ""
Else
ZeroToBlank = x
End If
End Function
One way is to declare a system environment variable using setx.
Running your batch with administration privilege try this:
setx PATHFILE "/path/file.xls" /M
Check if is declared:
set | find "PATHFILE"
And read it with the function Environ() to open you Workbook in your vbs:
Workbooks.Open Environ("PATHFILE")
EDIT
You do not need to use system environment variable (/m argument) as you can use only user environment. You need to just remember that the programs need to restart to read the user and system environment variable.
Set xlBook = GetObject("C:\Users\User\Documents\Super.xls")
For each wsheet in xlbook.worksheets
msgbox wsheet.name
next
Is how. Remember there are no excel constants in VBS, there is no dim x as something as vbs only does variants. so just dim x.
Other ways to a running copy of excel
Set GetExcelApp = GetObject("", "Excel.Application")
Msgbox GetExcelApp
To start a new excel and showing an excel constant replaced by it's value (43).
set xlapp = createobject("Excel.Application")
xlapp.Workbooks.Open "C:\Users\User\Documents\Super.xls"
'43 is 95/97 look up xlExcel9795 in object browser to see other options
xlapp.ActiveWorkbook.SaveAs "C:\Users\User\Documents\Super.xls", 43
my Access database exports a report in xls, that needs to be further reworked (some manual adjustments of columns etc. + vlookuping some comments from report from previous day).
Here is the part of the code I created so far:
Option Compare Database
Function Adjustment()
' First I want to prompt user to select the report from previous day*
Dim f As Object
Dim strFile As String
Dim strFolder As String
Dim varItem As Variant
Set f = Application.FileDialog(3)
f.AllowMultiSelect = True
If f.Show Then
For Each varItem In f.SelectedItems
strFile = Dir(varItem)
MsgBox (strFile)
Next
End If
Set f = Nothing
' here my Access database opens current report that has been exported
Dim xl As Object
Set xl = CreateObject("Excel.Application")
xl.Workbooks.Open ("I:\Temp\reports.xlsx")
xl.Visible = True
' in currently open report, I want fill cell I2 and J2 with VLOOKUP function referencing to previously selected file
Range("I2").FormulaR1C1 = "=VLOOKUP(RC7,'[" & strFile & "]SheetXY'!C7:C12,3,0)"
Range("J2").FormulaR1C1 = "=VLOOKUP(RC7,'[" & strFile & "]SheetXY!C7:C12,4,0)"
End function
Problem: I am being prompted every every time to select the file, when formula is being filled in I2 and J2, so how can I disable this and keep Access to reference strFile only once?
Question: So far, every first sheet in the refrenced workbook is called SheeyXY, but what if I would like to reference also a different Sheets (let`s say always the first sheet in the workbook no matter what its name is).
Maybe you can try this ..
Option Compare Database
Function Adjustment(SheetName as String) '---> add parameter such as "SheetXY"
' First I want to prompt user to select the report from previous day*
Dim f As Object
Dim strFolder As String
Dim varItem As Variant
Static strFile As String
If strFile = "" Then
Set f = Application.FileDialog(3)
f.AllowMultiSelect = True
If f.Show Then
For Each varItem In f.SelectedItems
strFile = Dir(varItem)
MsgBox (strFile)
Next
End If
Set f = Nothing
Endif
' here my Access database opens current report that has been exported
Dim xl As Object
Set xl = CreateObject("Excel.Application")
xl.Workbooks.Open ("I:\Temp\reports.xlsx")
xl.Visible = True
' in currently open report, I want fill cell I2 and J2 with VLOOKUP function referencing to previously selected file
Range("I2").FormulaR1C1 = "=VLOOKUP(RC7,'[" & strFile & "]" & SheetName & "'!C7:C12,3,0)"
Range("J2").FormulaR1C1 = "=VLOOKUP(RC7,'[" & strFile & "]" & SheetName & "'!C7:C12,4,0)"
End function
Have you tried taking out the .FormularR1C1 from those lines?
Also, I'm not sure exactly what you're trying to do with the sheet names, but you could probably hack something together from this?
Debug.Print Worksheets(1).Name
or
For Each ws In Worksheets
Debug.Print ws.Name
Next
UPDATE:
Try this, and report back?
With xl.Worksheets(1)
.Range("I2").FormulaR1C1 = "=VLOOKUP(RC7,[" & strFile & "]Sheet1!C7:C12,3,0)"
.Range("J2").FormulaR1C1 = "=VLOOKUP(RC7,[" & strFile & "]Sheet1!C7:C12,4,0)"
End With
So with the extra clarification of which range, and without the extra apostrophe
All right, this is my second attempt at a code, and the second VBA macro project I've been assigned to work on. I've been working to learn VBA as my first coding language for the last week and a half, so I apologize for silly mistakes. That said, straight to business. Here's what I put together for a word document macro:
Sub MacroToUpdateWordDocs()
'the following code gets and sets a open file command bar for word documents
Dim Filter, Caption, SelectedFile As String
Dim Finalrow As String
Dim FinalrowName As String
Filter = "xlsx Files (*.xlsx),*.xlsx"
Caption = "Please Select A .xlsx File, " & TheUser
SelectedFile = Application.GetOpenFilename(Filter, , Caption)
'check if value is blank if it is exit
Finalrow = Cells(Rows.Count, 1).End(xlUp).Row
FinalrowName = Finalrow + 1
If (Trim(SelectedFile) = "") Then
Exit Sub
Else
'setting up the inital word application object
Set auditmaster = CreateObject("excel.sheet")
'opening the document that is defined in the open file dialog
auditmaster.Application.Workbooks.Open (SelectedFile)
'ability to change wether it needs to burn cycles updating the UI
auditmaster.Visible = False
'declare excel sheet
Dim wdoc As Document
'set active sheet
Set wdoc = Application.ActiveDocument
Dim i As Integer
Dim u As Integer
Dim ColumnAOldAddy As String
Dim ColumnCNewAddy As String
u = 1
i = 1
'MsgBox (wordapp.ActiveDocument.Hyperlinks.Count)
'Sets up a loop to go through the Excel Audit file rows.
For i = 1 To auditmaster.ActiveSheet.Rows.Count
'Identifies ColumnAOldAddy and ColumnCNewAddy as columns A and C for each row i. Column A is the current hyperlink.address, C is the updated one.
ColumnAOldAddy = auditmaster.Cells(i, 1)
ColumnCNewAddy = auditmaster.Cells(i, 3)
'If C has a new hyperlink in it, then scan the hyperlinks in wdoc for a match to A, and replace it with C
If ColumnCNewAddy = Not Nothing Then
For u = 1 To doc.Hyperlinks.Count
'If the hyperlink matches.
If doc.Hyperlinks(u).Address = ColumnAOldAddy Then
'Change the links address.
doc.Hyperlinks(u).Address = ColumnCNewAddy
End If
'check the next hyperlink in wdoc
Next
End If
'makes sure the macro doesn't run on into infinity.
If i = Finalrow + 1 Then GoTo Donenow
'Cycles to the next row in the auditmaster workbook.
Next
Donenow:
'Now that we've gone through the auditmaster file, we close it.
auditmaster.ActiveSheet.Close SaveChanges:=wdDoNotSaveChanges
auditmaster.Quit SaveChanges:=wdDoNotSaveChanges
Set auditmaster = Nothing
End If
End Sub
So, this code is suppose to take a hyperlink audit file created by my first macro (The last bugs fixed and functioning wonderfully thanks to the Stack Overflow community!). The audit file has 3 columns and a row for each hyperlink it found in the target .docx: A = hyperlink address, B = Hyperlink displaytext, and C = the new Hyperlink address
When the code runs from the .docx file to be updated, it allows the user to choose the audit file. From there, it goes row by row to check if an updated hyperlink address has been written into the C column by the older audited address/display name, then searches the .docx file for the old hyperlink address and replaces it with the new hyperlink address. At that point, it finishes searching the document then moves on to the next row in the audit excel file.
My problem is that much of this code is copy/pasted out of code from an excel macro. I have been having a hell of a time figuring out how translate that code into something that identifies/references the word/excel documents appropriately. I'm hoping someone with more experience can take a peek at this macro and let me know where I've completely buggered up. It keeps giving me "Method or data member not found" errors all over the place currently, primarily concerning where I attempt to reference the audit excel file. I'm pretty sure that this is a relatively easy fix, but I don't have the vocabulary to figure out how to Google the answer!
Compiled OK, but not tested:
Sub MacroToUpdateWordDocs()
Dim Filter, Caption, SelectedFile As String
Dim Finalrow As String
Dim appXL As Object
Dim oWB As Object
Dim oSht As Object
Dim wdoc As Document
Dim ColumnAOldAddy As String
Dim ColumnCNewAddy As String
Dim i As Long
Dim h As Word.Hyperlink
Dim TheUser As String
Filter = "xlsx Files (*.xlsx),*.xlsx"
Caption = "Please Select A .xlsx File, " & TheUser
Set appXL = CreateObject("excel.application")
appXL.Visible = True
SelectedFile = appXL.GetOpenFilename(Filter, , Caption)
appXL.Visible = False
If Trim(SelectedFile) = "" Then
appXL.Quit
Exit Sub
Else
Set oWB = appXL.Workbooks.Open(SelectedFile)
Set oSht = oWB.worksheets(1)
Finalrow = oSht.Cells(oSht.Rows.Count, 1).End(-4162).Row '-4162=xlUp
End If
Set wdoc = Application.ActiveDocument
For i = 1 To Finalrow
ColumnAOldAddy = oSht.Cells(i, 1).Value
ColumnCNewAddy = oSht.Cells(i, 3).Value
If ColumnCNewAddy <> ColumnAOldAddy Then
For Each h In wdoc.Hyperlinks
If h.Address = ColumnAOldAddy Then
h.Address = ColumnCNewAddy
End If
Next h
End If
Next i
oWB.Close False
appXL.Quit
End Sub
I already have a macro that creates sheets and some other stuff. After a sheet has been created do I want to call another macro that copies data from a second excel (its open) to first and active excel file.
First I want to copy to headers, but I cant get that to work - keep getting errors.
Sub CopyData(sheetName as String)
Dim File as String, SheetData as String
File = "my file.xls"
SheetData = "name of sheet where data is"
# Copy headers to sheetName in main file
Workbooks(File).Worksheets(SheetData).Range("A1").Select # fails here: Method Select for class Range failed
Workbooks(File).Worksheets(SheetData).Range(Selection, Selection.End(xlToRight)).Select
Workbooks(File).Worksheets(SheetData).Selection.Copy ActiveWorkbook.Sheets(sheetName).Cells(1, 1)
End Sub
What is wrong ?
I really want to avoid having to make "my file.xls" active.
Edit: I had to give it up and copy the SheetData to target file as a new sheet, before it could work.
Find and select multiple rows
Two years later (Found this on Google, so for anyone else)... As has been mentioned above, you don't need to select anything. These three lines:
Workbooks(File).Worksheets(SheetData).Range("A1").Select
Workbooks(File).Worksheets(SheetData).Range(Selection, Selection.End(xlToRight)).Select
Workbooks(File).Worksheets(SheetData).Selection.Copy ActiveWorkbook.Sheets(sheetName).Cells(1, 1)
Can be replaced with
Workbooks(File).Worksheets(SheetData).Range(Workbooks(File).Worksheets(SheetData). _
Range("A1"), Workbooks(File).Worksheets(SheetData).Range("A1").End(xlToRight)).Copy _
Destination:=ActiveWorkbook.Sheets(sheetName).Cells(1, 1)
This should get around the select error.
Best practice is to open the source file (with a false visible status if you don't want to be bother) read your data and then we close it.
A working and clean code is avalaible on the link below :
http://vba-useful.blogspot.fr/2013/12/how-do-i-retrieve-data-from-another.html
Would you be happy to make "my file.xls" active if it didn't affect the screen? Turning off screen updating is the way to achieve this, it also has performance improvements (significant if you are doing looping while switching around worksheets / workbooks).
The command to do this is:
Application.ScreenUpdating = False
Don't forget to turn it back to True when your macros is finished.
I don't think you need to select anything at all. I opened two blank workbooks Book1 and Book2, put the value "A" in Range("A1") of Sheet1 in Book2, and submitted the following code in the immediate window -
Workbooks(2).Worksheets(1).Range("A1").Copy Workbooks(1).Worksheets(1).Range("A1")
The Range("A1") in Sheet1 of Book1 now contains "A".
Also, given the fact that in your code you are trying to copy from the ActiveWorkbook to "myfile.xls", the order seems to be reversed as the Copy method should be applied to a range in the ActiveWorkbook, and the destination (argument to the Copy function) should be the appropriate range in "myfile.xls".
I was in need of copying the data from one workbook to another using VBA. The requirement was as mentioned below 1. On pressing an Active X button open the dialogue to select the file from which the data needs to be copied. 2. On clicking OK the value should get copied from a cell / range to currently working workbook.
I did not want to use the open function because it opens the workbook which will be annoying
Below is the code that I wrote in the VBA. Any improvement or new alternative is welcome.
Code: Here I am copying the A1:C4 content from a workbook to the A1:C4 of current workbook
Private Sub CommandButton1_Click()
Dim BackUp As String
Dim cellCollection As New Collection
Dim strSourceSheetName As String
Dim strDestinationSheetName As String
strSourceSheetName = "Sheet1" 'Mention the Source Sheet Name of Source Workbook
strDestinationSheetName = "Sheet2" 'Mention the Destination Sheet Name of Destination Workbook
Set cellCollection = GetCellsFromRange("A1:C4") 'Mention the Range you want to copy data from Source Workbook
With Application.FileDialog(msoFileDialogOpen)
.AllowMultiSelect = False
.Show
'.Filters.Add "Macro Enabled Xl", "*.xlsm;", 1
For intWorkBookCount = 1 To .SelectedItems.Count
Dim strWorkBookName As String
strWorkBookName = .SelectedItems(intWorkBookCount)
For cellCount = 1 To cellCollection.Count
On Error GoTo ErrorHandler
BackUp = Sheets(strDestinationSheetName).Range(cellCollection.Item(cellCount))
Sheets(strDestinationSheetName).Range(cellCollection.Item(cellCount)) = GetData(strWorkBookName, strSourceSheetName, cellCollection.Item(cellCount))
Dim strTempValue As String
strTempValue = Sheets(strDestinationSheetName).Range(cellCollection.Item(cellCount)).Value
If (strTempValue = "0") Then
strTempValue = BackUp
End If
Sheets(strDestinationSheetName).Range(cellCollection.Item(cellCount)) = strTempValue
ErrorHandler:
If (Err.Number <> 0) Then
Sheets(strDestinationSheetName).Range(cellCollection.Item(cellCount)) = BackUp
Exit For
End If
Next cellCount
Next intWorkBookCount
End With
End Sub
Function GetCellsFromRange(RangeInScope As String) As Collection
Dim startCell As String
Dim endCell As String
Dim intStartColumn As Integer
Dim intEndColumn As Integer
Dim intStartRow As Integer
Dim intEndRow As Integer
Dim coll As New Collection
startCell = Left(RangeInScope, InStr(RangeInScope, ":") - 1)
endCell = Right(RangeInScope, Len(RangeInScope) - InStr(RangeInScope, ":"))
intStartColumn = Range(startCell).Column
intEndColumn = Range(endCell).Column
intStartRow = Range(startCell).Row
intEndRow = Range(endCell).Row
For lngColumnCount = intStartColumn To intEndColumn
For lngRowCount = intStartRow To intEndRow
coll.Add (Cells(lngRowCount, lngColumnCount).Address(RowAbsolute:=False, ColumnAbsolute:=False))
Next lngRowCount
Next lngColumnCount
Set GetCellsFromRange = coll
End Function
Function GetData(FileFullPath As String, SheetName As String, CellInScope As String) As String
Dim Path As String
Dim FileName As String
Dim strFinalValue As String
Dim doesSheetExist As Boolean
Path = FileFullPath
Path = StrReverse(Path)
FileName = StrReverse(Left(Path, InStr(Path, "\") - 1))
Path = StrReverse(Right(Path, Len(Path) - InStr(Path, "\") + 1))
strFinalValue = "='" & Path & "[" & FileName & "]" & SheetName & "'!" & CellInScope
GetData = strFinalValue
End Function