I have below code to open sharepoint 2010 document library's specific document based on filename (library has only excelfiles) but I am unable to read the metadata of that file. I tried with Builtin and custom document properties but there is not luck.
Sub OpenSharePointFile(StrSharePointUrl As String, strDocLibrary As String, FileNameWithExt As String)
Application.ScreenUpdating = False
Dim SPWorkbook As Workbook
Dim this As Workbook
Dim sh As Shape
Application.DisplayAlerts = False
Set SPWorkbook = Workbooks.Open(StrSharePointUrl & strDocLibrary & "\" & FileNameWithExt)
Application.DisplayAlerts = True
Set this = ThisWorkbook
If SPWorkbook Is Nothing Then
MsgBox "This product is not available"
Exit Sub
Else
'Copy Metadata
'ThisWorkbook.Sheets(Sht_Input.Name).Range("C3").Value = SPWorkbook.BuiltinDocumentProperties("Title")
'ThisWorkbook.Sheets(Sht_Input.Name).Range("C4").Value = SPWorkbook.BuiltinDocumentProperties("Business Unit")
'ThisWorkbook.Sheets(Sht_Input.Name).Range("C5").Value = SPWorkbook.BuiltinDocumentProperties("ItemNo")
'ThisWorkbook.Sheets(Sht_Input.Name).Range("C6").Value = SPWorkbook.BuiltinDocumentProperties("ECO Type")
'ThisWorkbook.Sheets(Sht_Input.Name).Range("C7").Value = SPWorkbook.BuiltinDocumentProperties("ItemDescription")
'ThisWorkbook.Sheets(Sht_Input.Name).Range("C8").Value = SPWorkbook.BuiltinDocumentProperties("Status")
'ThisWorkbook.Sheets(Sht_Input.Name).Range("C9").Value = SPWorkbook.BuiltinDocumentProperties("CasmasUpdate")
'ThisWorkbook.Sheets(Sht_Input.Name).Range("E3").Value = SPWorkbook.BuiltinDocumentProperties("LabelData")
'ThisWorkbook.Sheets(Sht_Input.Name).Range("E4").Value = SPWorkbook.BuiltinDocumentProperties("SpqWhActive")
'ThisWorkbook.Sheets(Sht_Input.Name).Range("E5").Value = SPWorkbook.BuiltinDocumentProperties("I2of5Label")
'ThisWorkbook.Sheets(Sht_Input.Name).Range("E6").Value = SPWorkbook.BuiltinDocumentProperties("TiXHi")
'ThisWorkbook.Sheets(Sht_Input.Name).Range("E7").Value = SPWorkbook.BuiltinDocumentProperties("SpecSent")
'ThisWorkbook.Sheets(Sht_Input.Name).Range("E8").Value = SPWorkbook.BuiltinDocumentProperties("CasmasToYes")
'ThisWorkbook.Sheets(Sht_Input.Name).Range("E9").Value = SPWorkbook.BuiltinDocumentProperties("EcoOwner")
'Copy ECO Summary:
ThisWorkbook.Sheets(Sht_Input.Name).Range("B12").Value = SPWorkbook.Sheets(Sht_Input.Name).Range("B12").Value
'Copy Ref ID
ThisWorkbook.Sheets(Sht_Input.Name).Range("D14").Value = SPWorkbook.Sheets(Sht_Input.Name).Range("D14").Value
'Copy THIS ITEM
SPWorkbook.Sheets(Sht_Input.Name).Range("C14:C74" & lRow).Copy
ThisWorkbook.Sheets(Sht_Input.Name).Range("C14").PasteSpecial xlPasteValues
'Delete from this workbook if available and Copy Shape if available in Sharepoint
If ThisWorkbook.Sheets(Sht_LCEncodingInfo.Name).Shapes.Count = 2 Then
For Each sh In ThisWorkbook.Sheets(Sht_LCEncodingInfo.Name).Shapes
If sh.Name <> "Picture 1" Then
sh.Delete
End If
Next
End If
If SPWorkbook.Sheets(Sht_LCEncodingInfo.Name).Shapes.Count = 2 Then
For Each sh In SPWorkbook.Sheets(Sht_LCEncodingInfo.Name).Shapes
If sh.Name <> "Picture 1" Then
sh.Height = 150 ' 138.96 '1.93"
sh.Width = 150 ' 228.24 '3.17"
sh.Copy
Application.Goto ThisWorkbook.Sheets(Sht_LCEncodingInfo.Name).Range("F9")
ActiveSheet.Paste
End If
Next
ThisWorkbook.Sheets(Sht_LCEncodingInfo.Name).Range("G2").Select
End If
'Activate Input sheet
ThisWorkbook.Sheets(Sht_Input.Name).Activate
ThisWorkbook.Sheets(Sht_Input.Name).Range("C3").Select
Application.DisplayAlerts = False
SPWorkbook.Close
Application.DisplayAlerts = True
MsgBox "Product Details fetched."
End If
Application.ScreenUpdating = True
End Sub
Try using ActiveWorkbook.ContentTypeProperties("Your column name")
instead of SPWorkbook.BuiltinDocumentProperties("Your column name")
Related
I am trying to look through data that a user has selected in a listbox, when the user clicks "Reserve offcuts" then all the selected lines of data that I have copied over on sheet "Offcut Basket" is then placed onto the database worksheet which is labled as "wo2" I want my code to then look through each line of column E and if that ID matches the ID on the database sheet it will then input the value as "Snumber" which is the value which is captured from the textbox on the userform in the column next to the ID
my Problem is that my code that looks through each cell is asking for an object, I see that i need to declare the objects meaning on which sheet i need to look through, but just a better understanding of where i have put my loop will be a great help. Thanks everyone
Private Sub CommandButton11_Click()
'Reserve offcuts with job number
If Offcut11.OffcutJob.Value = "" Then
MsgBox "Please insert SAGE job number!", vbExclamation, "JDS"
Exit Sub
End If
Dim snumber As String
snumber = Offcut11.OffcutJob.Value
Dim wo1 As Workbook
Dim wo2 As Workbook
Set wo1 = Workbooks("Fabrication Schedule v2")
Do
Set wo2 = Workbooks.Open(Filename:="J:\Database\Offcut Database.xlsx")
If wo2.ReadOnly Then Application.Wait Now + TimeSerial(0, 0, 1)
Loop Until Not wo2.ReadOnly
Application.Visible = False
Application.ScreenUpdating = False
wo1.Activate
Sheets("Offcut Basket").Activate
Range("A2:F200").Copy
wo2.Activate
Sheets("Offcut Basket").Activate
Range("A1").PasteSpecial xlPasteValues
Dim acr As String
Dim v As Range
Set v = Worksheets("Offcut Basket").Cells(Worksheets("Offcut Basket").Rows.Count, "E").End(xlUp)
With Worksheets("Offcut Database")
For Each cell In .Range(.Cells(2, "E"), .Cells(.Rows.Count, "E").End(xlUp))
If Int(cell.Value2) = Int(r.Value2) Then
Cells(v.Row, 2).Select
acr = ActiveCell.Row
Cells(acr, "F").Value = snumber
End If
Next cell
End With
Application.DisplayAlerts = False
wo2.Save
wo2.Close
wo1.Activate
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox "Offcuts have been reserved", vbExclamation, "JDS"
End Sub
I figured it out,
Private Sub CommandButton11_Click()
'Reserve offcuts with job number
If Offcut11.OffcutJob.Value = "" Then
MsgBox "Please insert SAGE job number!", vbExclamation, "JDS"
Exit Sub
End If
Dim snumber As String
snumber = Offcut11.OffcutJob.Value
Dim wo1 As Workbook
Dim wo2 As Workbook
Set wo1 = Workbooks("Fabrication Schedule v2")
Do
Set wo2 = Workbooks.Open(Filename:="J:\Database\Offcut Database.xlsx")
If wo2.ReadOnly Then Application.Wait Now + TimeSerial(0, 0, 1)
Loop Until Not wo2.ReadOnly
Application.Visible = False
Application.ScreenUpdating = False
wo1.Activate
Sheets("Offcut Basket").Activate
Range("A2:F200").Copy
wo2.Activate
Sheets("Offcut Basket").Activate
Range("A1").PasteSpecial xlPasteValues
Dim acr As String
Dim v As Range
Dim Found As Range
Set v = Sheets("Offcut Basket").Range("E1", Range("E" & Rows.Count).End(xlUp))
For Each cell In v
Sheets("Offcut Database").Activate
Set Found = Sheets("Offcut Database").Range("A2", Range("E" & Rows.Count).End(xlUp)).Find(cell, LookAt:=xlWhole)
Cells(Found.Row, 2).Select
acr = ActiveCell.Row
Cells(acr, "F").Value = snumber
Next cell
Application.DisplayAlerts = False
wo2.Save
wo2.Close
wo1.Activate
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox "Offcuts have been reserved", vbExclamation, "JDS"
End Sub
I am having trouble debugging my code. I have an array with the criterial of an autofilter column. My code is supposed to loop through the array, open a set of files and copy-paste information into my workbook.
When I run the code it does not autofiler to the desired criterial and shows a Run-time error 1004. I already tried searching for solutions or similar problems, but found nothing. I also tried recording a macro to change the approach, but when trying to implement the loop it does not work :(
Any help is appreaciated!
Sub Update_Database()
Dim directory As String
Dim fileName As String
Dim my_array() As String
Dim iLoop As Integer
ReDim my_array(18)
my_array(0) = "Aneng"
my_array(1) = "Bayswater"
my_array(2) = "Bad Blankenburg"
my_array(3) = "Halstead"
my_array(4) = "Jorf Lasfar"
my_array(5) = "Kolkatta"
my_array(6) = "Marysville"
my_array(7) = "Northeim"
my_array(8) = "Ponta Grossa"
my_array(9) = "Puchov"
my_array(10) = "Renca"
my_array(11) = "Padre Hurtado"
my_array(12) = "Shanxi"
my_array(13) = "San Luis Potosi"
my_array(14) = "Szeged"
my_array(15) = "Tampere"
my_array(16) = "Uitenhage"
my_array(17) = "Veliki Crljeni"
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
.Show
directory = .SelectedItems(1)
Err.Clear
End With
fileName = Dir(directory & "\", vbReadOnly)
Dim mwb As Workbook
Set mwb = Workbooks("OEE_Database_Final.xlsm")
Do While fileName <> ""
For iLoop = LBound(my_array) To UBound(my_array)
On erro GoTo ProcExit
With Workbooks.Open(fileName:=directory & "\" & fileName, UpdateLinks:=False, ReadOnly:=True)
Selection.AutoFilter Field:=1, Criterial:=my_array(iLoop)
mwb.Worksheets(8).Range("O9:Z2945") = .Worksheets(8).Range("O9:Z2945").Value2
.Close SaveChanges:=False
End With
fileName = Dir
Next iLoop
Loop
ActiveSheet.ShowAllData
ProcExit:
Exit Sub
End Sub
I'm writing a procedure to update the components in one macro-enabled Excel workbook (Destination) from another macro-enabled Excel workbook (Source). The end result is to make the Destination components (worksheets, user forms, modules, etc.) match the Source components.
So far I have successfully (1) Added components from source that are not found in destination, (2) Replaced worksheet(s) with newer versions, (3) Globally updated the code in all modules, class modules and user forms, and (4) Updated miscellaneous cell formulas and values in various worksheets.
Where I have been struggling is deleting components in destination that are not found in source. I've been trying all kinds of approaches and believe I'm close but can't get past various errors in the actual VBComponents.Remove line. Here's my code:
Sub UpdateDest()
'Purpose:
'Sources: (1) https://www.excel-easy.com/vba/examples/import-sheets.html
' (2) https://stackoverflow.com/questions/16174469/unprotect-vbDestProject-from-vb-code
' (3) https://stackoverflow.com/questions/18497527/copy-vba-code-from-a-sheet-in-one-workbook-to-another
'=== Declare Variables
Dim booCompFound As Boolean
Dim cmSrc As CodeModule, cmDest As CodeModule
Dim xlWBDest As Excel.Workbook, xlWSDest As Excel.Worksheet
Dim xlWBSrc As Excel.Workbook, xlWSSrc As Excel.Worksheet
Dim i As Integer, j As Integer
Dim lngVBUnlocked As Long
Dim vbDestComp As Object, vbDestComps As Object, vbDestProj As Object, vbDestMod As Object
Dim vbSrcComp As Object, vbSrcComps As Object, vbSrcProj As Object, vbSrcMod As Object
Dim modModule As Object
Dim strDestName As String, strDestPath As String, strSrcName As String, strSrcPath As String
Dim strUpdName As String, strUpdPath As String
'On Error GoTo ErrorHandler
'=== Initialize Variables and Prepare for Execution
Application.ScreenUpdating = True
Application.DisplayAlerts = True
strUpdPath = ThisWorkbook.Path & "\"
'=== (Code execution)
'--- Select Dest and source workbooks for the update, and remove workbook, worksheet and VBA Project protection from both
strSrcPath = Application.GetOpenFilename(Title:="Select SOURCE workbook for the update", FileFilter:="Excel Files *.xls* (*.xls*),")
If strSrcPath = "" Then
MsgBox "No source workbook was selected.", vbExclamation, "Sorry!"
Exit Sub
Else
Set xlWBSrc = Workbooks.Open(strSrcPath)
UnprotectAll xlWBSrc
'For Each xlWSSrc In xlWBSrc.Worksheets
' xlWSSrc.Visible = xlSheetVisible
'Next xlWSSrc
Set vbSrcProj = xlWBSrc.VBProject
lngVBUnlocked = UnlockProject(vbSrcProj, "FMD090")
Debug.Print lngVBUnlocked
If lngVBUnlocked <> 0 And lngVBUnlocked <> 2 Then
MsgBox "The source VB Project could not be unlocked.", vbExclamation, "Error!"
Exit Sub
Else
Set vbSrcComps = vbSrcProj.VBComponents
End If
End If
strDestPath = Application.GetOpenFilename(Title:="Select DESTINATION workbook to update", FileFilter:="Excel Files *.xls* (*.xls*),")
If strDestPath = "" Then
MsgBox "No destination workbook was selected.", vbExclamation, "Sorry!"
Exit Sub
Else
Set xlWBDest = Workbooks.Open(strDestPath)
UnprotectAll xlWBDest
'For Each xlWSDest In xlWBDest.Worksheets
' xlWSDest.Visible = xlSheetVisible
'Next xlWSDest
Set vbDestProj = xlWBDest.VBProject
lngVBUnlocked = UnlockProject(vbDestProj, "FMD090")
Debug.Print lngVBUnlocked
If lngVBUnlocked <> 0 And lngVBUnlocked <> 2 Then
MsgBox "The destination VB Project could not be unlocked.", vbExclamation, "Error!"
Exit Sub
Else
Set vbDestComps = vbDestProj.VBComponents
End If
End If
'--- Add components from source that are not found in destination
For Each vbSrcComp In vbSrcComps
Debug.Print vbSrcComp.Name
booCompFound = False
For Each vbDestComp In vbDestComps
If vbSrcComp.Name = vbDestComp.Name Then
booCompFound = True
Exit For
End If
Next vbDestComp
If booCompFound = False Then
Application.EnableEvents = False
vbSrcComp.Export strSrcPath & vbSrcComp.Name
vbDestComps.Import strSrcPath & vbSrcComp.Name
Kill strSrcPath & vbSrcComp.Name
Application.EnableEvents = True
End If
Next vbSrcComp
'--- Delete components in destination that are not found in source
Set vbDestComps = vbDestProj.VBComponents
For i = vbDestComps.Count To 1 Step -1
'For Each vbDestComp In vbDestComps
booCompFound = False
For Each vbSrcComp In vbSrcComps
Debug.Print "Src: "; vbSrcComp.Name; " Dest: "; vbDestComps(i).Name
If vbDestComps(i).Name = vbSrcComp.Name Then
booCompFound = True
Exit For
End If
Next vbSrcComp
If booCompFound = False Then
Application.EnableEvents = False
'>>> PROBLEM LINE
vbDestProj.VBComponents.Remove vbDestComps(i)
'<<<
Application.EnableEvents = True
End If
'Next vbDestComp
Next i
'--- Replace worksheet(s) with newer versions
strUpdName = "Lists_WS_3_1.xlsx"
If Dir(strUpdPath & strUpdName) <> "" Then
Application.EnableEvents = False
Set xlWBSrc = Workbooks.Open(strUpdPath & strUpdName)
xlWBDest.Worksheets("Lists").Visible = xlSheetVisible
Application.DisplayAlerts = False
xlWBDest.Worksheets("Lists").Name = "Lists_Old"
xlWBSrc.Worksheets("Lists").Copy After:=xlWBDest.Worksheets("FYMILES")
xlWBDest.Worksheets("Lists_Old").Delete
xlWBSrc.Close
Application.EnableEvents = True
Else
MsgBox "The file " & strUpdName & " is missing.", vbExclamation, "File Missing!"
Exit Sub
End If
'--- Globally update code in modules, class modules and user forms
For Each vbSrcComp In vbSrcComps
Set cmSrc = vbSrcComp.CodeModule
Debug.Print vbSrcComp.Name
Set cmDest = vbDestComps(vbSrcComp.Name).CodeModule
If cmSrc.CountOfLines > 0 Then
Application.EnableEvents = False
cmDest.DeleteLines 1, cmDest.CountOfLines 'Delete all lines in Dest component
cmDest.AddFromString cmSrc.Lines(1, cmSrc.CountOfLines) 'Copy all lines from source component to Dest component
Application.EnableEvents = True
End If
Next vbSrcComp
'--- Update miscellaneous cell formulas and values
Application.EnableEvents = False
xlWBDest.Sheets("Inventory Data and July").Range("E2").Formula = "=TEXT(Lists!$O$5, " & Chr(34) & "000" & Chr(34) & ")"
Application.EnableEvents = True
'=== Error Handling
ErrorHandler:
Application.EnableEvents = True
'=== Release Variables and Cleanup
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
The problem code is about 2/3rds of the way down following '>>> PROBLEM LINE. This line of code produces a run-time error 5, invalid procedure call or argument when attempting to delete the Sheet18 code module.
During the run the original Sheet16 (Lists) is removed and replaced with a new Lists worksheet that Excel numbers Sheet18. After a weekend of contemplation I believe the issue stems from component naming. Attempting to address this, the code references the component names, but VB Properties for the new sheet are (Name) = (Sheet18) and Name = Lists (note the parentheses).
I've now tried saving the workbook following each operation without any change in the error or on what part of the structure the error occurs.
As it is currently written I'm looping backward through the destination components collection and attempting to delete when a component in Destination isn't found in Source. Commented out are the remnants of the original forward loop that also didn't work. I've tried many variations and either get an invalid procedure call or that the property or method isn't found in the object.
I've spend a day playing with this. Please take a look and help me see the light!
I'm running Excel 2016
Following on # Comintern's comment, I added tests to ensure the Remove method was only applied to non-document modules. This is the rewritten code block for removing the modules:
'--- Delete non-document components in destination that are not found in source
Set vbDestComps = vbDestProj.VBComponents
For Each vbDestComp In vbDestComps
If vbDestComp.Type >= 1 And vbDestComp.Type <= 3 Then
booCompFound = False
For Each vbSrcComp In vbSrcComps
Debug.Print "Src: "; vbSrcComp.Name; " Dest: "; vbDestComp.Name; " Type: "; vbDestComp.Type
If vbDestComp.Name = vbSrcComp.Name Then
booCompFound = True
Exit For
End If
Next vbSrcComp
If booCompFound = False Then
Application.EnableEvents = False
vbDestProj.VBComponents.Remove vbDestComp
Application.EnableEvents = True
End If
End If
Next vbDestComp
I need to open a dialog box and select a workbook. Then copy the data placed in that workbook (which has only 1 sheet with same name all the time).
I want to do the process for many workbooks by using a loop for vbyesno.
This is the only part which is not working because I want to paste data under Range("a14"), then loop and then paste under the data pasted in a14.
Below is the macro which is being called from another macro.
Sub prompt()
Application.DisplayAlerts = False
Dim Target_Workbook As Workbook
Dim Source_Workbook As Workbook
Dim Target_Path As Range
d = MsgBox("Add record?", vbYesNoCancel + vbInformation)
If d = vbNo Then
ActiveSheet.Range("a13").value = "No data Found"
ActiveSheet.Range("a13").Font.Bold = True
ThisWorkbook.Save
ElseIf d = vbCancel Then
Sheets("MPSA").Delete
ThisWorkbook.Save
ElseIf d = vbYes Then
Sheets("MPSA").Range("a14").value = "NAME"
Sheets("MPSA").Range("b14").value = "NUMBER"
Sheets("MPSA").Range("c14").value = "AGR NUMBER"
Sheets("MPSA").Range("d14").value = "ENTITY NAME"
Sheets("MPSA").Range("e14").value = "GROUP"
Sheets("MPSA").Range("f14").value = "DELIVERABLE"
Sheets("MPSA").Range("g14").value = "DELIVERAB"
Sheets("MPSA").Range("h14").value = "IS COMPON"
Sheets("MPSA").Range("i14").value = "PACKAGE"
Sheets("MPSA").Range("j14").value = "ORDERS"
Sheets("MPSA").Range("k14").value = "LICNTITY"
Sheets("MPSA").Range("l14").value = "QUANTITY"
Sheets("MPSA").Range("m14").value = "ORDERANUMBER"
Sheets("MPSA").Range("n14").value = "ORDERAM NAME"
Sheets("MPSA").Range("o14").value = "PAC NUMBER"
Sheets("MPSA").Range("p14").value = "PACKAGAME"
Sheets("MPSA").Range("q14").value = "ITTION"
Sheets("MPSA").Range("r14").value = "LICENSE TYPE"
Sheets("MPSA").Range("s14").value = "ITEM VERSION"
Sheets("MPSA").Range("t14").value = "REAGE"
Sheets("MPSA").Range("u14").value = "CLIIT"
Sheets("MPSA").Range("v14").value = "LICEAME"
Sheets("MPSA").Range("w14").value = "ASSATE"
Sheets("MPSA").Range("x14").value = "ASSTE"
Sheets("MPSA").Range("y14").value = "ENTITTUS"
Sheets("MPSA").Range("z14").value = "ASSGORY"
Sheets("MPSA").Range("aa14").value = "PURCHAYPE"
Sheets("MPSA").Range("ab14").value = "BILLTHOD"
Sheets("MPSA").Range("ac14").value = "SALETER"
Cells.Columns.AutoFit
Target_Path = Application.GetOpenFilename
Set Target_Workbook = Workbooks.Open(Target_Path)
Set Source_Workbook = ThisWorkbook
Target_Data = Target_Workbook.Sheets(1).Range("A1").CurrentRegion.Copy
Target_Workbook.Close
Source_Workbook.Sheets("MPSA").Range("a14").End(xlDown).Offset(1, 0).PasteSpecial = Target_Data
ActiveCell.EntireRow.Delete
ThisWorkbook.Save
ThisWorkbook.Save
End If
End Sub
I was going to propose a mechanism to achieve the loop, supposing that your current code is somewhere near what you want to achieve. But I found many mistakes so I had to refactor it, hopefully it will get you a step further.
The following code will continue looping until user presses Cancel in the file dialog box:
Sub prompt()
Dim d As VbMsgBoxResult: d = MsgBox("Add record?", vbYesNoCancel + vbInformation)
If d = vbNo Then
Sheets("MPSA").Range("a13").value = "No data Found"
Sheets("MPSA").Range("a13").Font.Bold = True
ThisWorkbook.Save
Exit Sub
End If
If d = vbCancel Then
Sheets("MPSA").Delete
ThisWorkbook.Save
Exit Sub
End If
On Error GoTo Cleanup
Application.DisplayAlerts = False: Application.EnableEvents = False: Application.ScreenUpdating = False
Sheets("MPSA").Range("a14:ac14").value = Array( _
"NAME", "NUMBER", "AGR NUMBER", "ENTITY NAME", "GROUP", "DELIVERABLE", "DELIVERAB", "IS COMPON", _
"PACKAGE", "ORDERS", "LICNTITY", "QUANTITY", "ORDERANUMBER", "ORDERAM NAME", "PAC NUMBER", "PACKAGAME", _
"ITTION", "LICENSE TYPE", "ITEM VERSION", "REAGE", "CLIIT", "LICEAME", "ASSATE", "ASSTE", _
"ENTITTUS", "ASSGORY", "PURCHAYPE", "BILLTHOD", "SALETER")
Sheets("MPSA").Columns.AutoFit
Dim Target_Path: Target_Path = Application.GetOpenFilename
Do While Target_Path <> False ' <-- loop until user cancels
Dim Target_Workbook As Workbook: Set Target_Workbook = Workbooks.Open(Target_Path)
Target_Workbook.Sheets(1).Range("A1").CurrentRegion.Copy _
ThisWorkbook.Sheets("MPSA").Range("a1000000").End(xlUp).Offset(1)
Target_Workbook.Close False
ActiveCell.EntireRow.Delete
ThisWorkbook.Save
Target_Path = Application.GetOpenFilename
Loop
Cleanup:
If Err.Number <> 0 Then MsgBox "Something went wrong: " & vbCrLf & Err.Description
Application.DisplayAlerts = True: Application.EnableEvents = True: Application.ScreenUpdating = True
End Sub
I have exhausted my search capabilities looking for a solution to this. Here is an outline of what I would like to do:
User opens macro-enabled Excel file
Immediate prompt displays for user to enter or select file path of desired workbooks. They will need to select two files, and the file names may not be consistent
After entering the file locations, the first worksheet from the first file selection will be copied to the first worksheet of the macro-enabled workbook, and the first worksheet of the second file selection will be copied to the second worksheet of the macro-enabled workbook.
I've come across some references to ADO, but I am really not familiar with that yet.
Edit: I have found a code to import data from a closed file. I will need to tweak the range to return the variable results.
Private Function GetValue(path, file, sheet, ref)
path = "C:\Users\crathbun\Desktop"
file = "test.xlsx"
sheet = "Sheet1"
ref = "A1:R30"
' Retrieves a value from a closed workbook
Dim arg As String
' Make sure the file exists
If Right(path, 1) <> "\" Then path = path & "\"
If Dir(path & file) = "" Then
GetValue = "File Not Found"
Exit Function
End If
' Create the argument
arg = "'" & path & "[" & file & "]" & sheet & "'!" & _
Range(ref).Range("A1").Address(, , xlR1C1)
' Execute an XLM macro
GetValue = ExecuteExcel4Macro(arg)
End Function
Sub TestGetValue()
path = "C:\Users\crathbun\Desktop"
file = "test"
sheet = "Sheet1"
Application.ScreenUpdating = False
For r = 1 To 30
For C = 1 To 18
a = Cells(r, C).Address
Cells(r, C) = GetValue(path, file, sheet, a)
Next C
Next r
Application.ScreenUpdating = True
End Sub
Now, I need a command button or userform that will immediately prompt the user to define a file path, and import the data from that file.
I don't mind if the files are opened during process. I just didn't want the user to have to open the files individually. I just need them to be able to select or navigate to the desired files
Here is a basic code. This code asks user to select two files and then imports the relevant sheet into the current workbook. I have given two options. Take your pick :)
TRIED AND TESTED
OPTION 1 (Import the Sheets directly instead of copying into sheet1 and 2)
Option Explicit
Sub Sample()
Dim wb1 As Workbook, wb2 As Workbook
Dim Ret1, Ret2
Set wb1 = ActiveWorkbook
'~~> Get the first File
Ret1 = Application.GetOpenFilename("Excel Files (*.xls*), *.xls*", _
, "Please select first file")
If Ret1 = False Then Exit Sub
'~~> Get the 2nd File
Ret2 = Application.GetOpenFilename("Excel Files (*.xls*), *.xls*", _
, "Please select Second file")
If Ret2 = False Then Exit Sub
Set wb2 = Workbooks.Open(Ret1)
wb2.Sheets(1).Copy Before:=wb1.Sheets(1)
ActiveSheet.Name = "Blah Blah 1"
wb2.Close SaveChanges:=False
Set wb2 = Workbooks.Open(Ret2)
wb2.Sheets(1).Copy After:=wb1.Sheets(1)
ActiveSheet.Name = "Blah Blah 2"
wb2.Close SaveChanges:=False
Set wb2 = Nothing
Set wb1 = Nothing
End Sub
OPTION 2 (Import the Sheets contents into sheet1 and 2)
Option Explicit
Sub Sample()
Dim wb1 As Workbook, wb2 As Workbook
Dim Ret1, Ret2
Set wb1 = ActiveWorkbook
'~~> Get the first File
Ret1 = Application.GetOpenFilename("Excel Files (*.xls*), *.xls*", _
, "Please select first file")
If Ret1 = False Then Exit Sub
'~~> Get the 2nd File
Ret2 = Application.GetOpenFilename("Excel Files (*.xls*), *.xls*", _
, "Please select Second file")
If Ret2 = False Then Exit Sub
Set wb2 = Workbooks.Open(Ret1)
wb2.Sheets(1).Cells.Copy wb1.Sheets(1).Cells
wb2.Close SaveChanges:=False
Set wb2 = Workbooks.Open(Ret2)
wb2.Sheets(1).Cells.Copy wb1.Sheets(2).Cells
wb2.Close SaveChanges:=False
Set wb2 = Nothing
Set wb1 = Nothing
End Sub
The function below reads data from a closed Excel file and returns the result in an array. It loses formatting, formulas etc. You might want to call the isArrayEmpty function (at the bottom) in your main code to test that the function returned something.
Public Function getDataFromClosedExcelFile(parExcelFileName As String, parSheetName As String) As Variant
'see http://www.ozgrid.com/forum/showthread.php?t=19559
'returns an array (1 to nRows, 1 to nCols) which should be tested with isArrayEmpty in the calling function
Dim locConnection As New ADODB.Connection
Dim locRst As New ADODB.Recordset
Dim locConnectionString As String
Dim locQuery As String
Dim locCols As Variant
Dim locResult As Variant
Dim i As Long
Dim j As Long
On Error GoTo error_handler
locConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;" _
& "Data Source=" & parExcelFileName & ";" _
& "Extended Properties=""Excel 8.0;HDR=YES"";"
locQuery = "SELECT * FROM [" & parSheetName & "$]"
locConnection.Open ConnectionString:=locConnectionString
locRst.Open Source:=locQuery, ActiveConnection:=locConnection
If locRst.EOF Then 'Empty sheet or only one row
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''''' FIX: an empty sheet returns "F1"
'''''' http://support.microsoft.com/kb/318373
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
If locRst.Fields.Count = 1 And locRst.Fields(0).Name = "F1" Then Exit Function 'Empty sheet
ReDim locResult(1 To 1, 1 To locRst.Fields.Count) As Variant
For i = 1 To locRst.Fields.Count
locResult(1, i) = locRst.Fields(i - 1).Name
Next i
Else
locCols = locRst.GetRows
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''''' FIX: an empty sheet returns "F1"
'''''' http://support.microsoft.com/kb/318373
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
If locRst.Fields.Count = 1 And locRst.Fields(0).Name = "F1" And UBound(locCols, 2) = 0 And locCols(0, 0) = "" Then Exit Function 'Empty sheet
ReDim locResult(1 To UBound(locCols, 2) + 2, 1 To UBound(locCols, 1) + 1) As Variant
If locRst.Fields.Count <> UBound(locCols, 1) + 1 Then Exit Function 'Not supposed to happen
For j = 1 To UBound(locResult, 2)
locResult(1, j) = locRst.Fields(j - 1).Name
Next j
For i = 2 To UBound(locResult, 1)
For j = 1 To UBound(locResult, 2)
locResult(i, j) = locCols(j - 1, i - 2)
Next j
Next i
End If
locRst.Close
locConnection.Close
Set locRst = Nothing
Set locConnection = Nothing
getDataFromClosedExcelFile = locResult
Exit Function
error_handler:
'Wrong file name, sheet name, or other errors...
'Errors (#N/A, etc) on the sheet should be replaced by Null but should not raise an error
If locRst.State = ADODB.adStateOpen Then locRst.Close
If locConnection.State = ADODB.adStateOpen Then locConnection.Close
Set locRst = Nothing
Set locConnection = Nothing
End Function
Public Function isArrayEmpty(parArray As Variant) As Boolean
'Returns false if not an array or dynamic array that has not been initialised (ReDim) or has been erased (Erase)
If IsArray(parArray) = False Then isArrayEmpty = True
On Error Resume Next
If UBound(parArray) < LBound(parArray) Then isArrayEmpty = True: Exit Function Else: isArrayEmpty = False
End Function
Sample use:
Sub test()
Dim data As Variant
data = getDataFromClosedExcelFile("myFile.xls", "Sheet1")
If Not isArrayEmpty(data) Then
'Copies content on active sheet
ActiveSheet.Cells(1,1).Resize(UBound(data,1), UBound(data,2)) = data
End If
End Sub