Hub workbook as a medium to multiple workbooks

[DWRgt2885]

Hi all!

I've created a user form in which I submit data on orders i'm following up on. 5 other co workers have a copy of that workbook. Every time we click the "Submit" button on the user form, it adds the form data to the next blank row in the current workbook, but it ALSO adds the form data to the next blank row in a closed workbook called "Hub". The idea is that we can all update the "Hub" sheet with out running into a "read only" issue.

Now, i need to take the data from the "Hub" sheet and update all the User workbooks with any new data that was added to "Hub". I'd like this to happen when a user opens his/her User Form.

I've messed around with a few different codes, but they seem overly complicated when I feel like this be pretty simply.

Copy used range from Hub > add data to current workbook starting in first blank cell in Column A

I read the below article, and my main concern is the range address differs every day. My goal is to have every User workbook updated as often as possible with data from the "Hub" workbook[h=1]Copy range from closed workbook and paste into active workbook[/h]
I like the below code, but i don't want anyone to have to manually select the file, could someone guide me into modifying this to a specific workbook or point me in a general direction?

[Sub ImportDatafromcloseworkbook()'Update 20150707
Dim xWb As Workbook
Dim xAddWb As Workbook
Dim xRng1 As Range
Dim xRng2 As Range
Set xWb = Application.ActiveWorkbook
xTitleId = "KutoolsforExcel"
With Application.FileDialog(msoFileDialogOpen)
.Filters.Clear
.Filters.Add "Excel 2007-13", "*.xlsx; *.xlsm; *.xlsa"
.AllowMultiSelect = False
.Show
If .SelectedItems.Count > 0 Then
Application.Workbooks.Open .SelectedItems(1)
Set xAddWb = Application.ActiveWorkbook
Set xRng1 = sh4.Range(Rows.Count, 1).End(xlUp).Row
xWb.Activate
Set xRng2 = Range("A1").End(xlDown).Offset(1, 0).Select
xRng1.Copy xRng2
xRng2.CurrentRegion.EntireColumn.AutoFit
xAddWb.Close False
End If
End With
End Sub]

 

[dmt32]

Hi,
try following:

Place in a STANDARD module:

Sub RefreshFromHub(ByVal FileName As String, Optional ByVal Password As String)


    Dim wbHub As Workbook
    Dim CopyFromRange As Range, CopyToRange As Range
    
    On Error GoTo exitsub
    If Not Dir(FileName, vbDirectory) = vbNullString Then
    Application.ScreenUpdating = False
    
    Set CopyToRange = ThisWorkbook.Sheets(1).Range("A1").End(xlDown).Offset(1, 0)
    
    Set wbHub = Application.Workbooks.Open(FileName, ReadOnly:=True, Password:=Password)
    
    Set CopyFromRange = wbHub.Sheets(1).UsedRange
    
    CopyFromRange.Copy CopyToRange
    CopyToRange.CurrentRegion.EntireColumn.AutoFit
    
    wbHub.Close False
    
    Else
     Err.Raise 53
    End If
    
    Set wbHub = Nothing
    
exitsub:
    If Not wbHub Is Nothing Then wbHub.Close False
    Application.ScreenUpdating = True
    If Err > 0 Then MsgBox (Error(Err)), 64, "Error"
End Sub

It is assumed that the sheets being copied from / to are the FIRST sheet in each workbook - change value shown in RED as required.


Place following in your Userform CODE Page:

Private Sub UserForm_Initialize()
    RefreshFromHub "P:\Folder1\Folder2\Hub.xlsx", "optionalmypassword"
End Sub

Change the FilePath / FileName shown in RED as required.

Password to OPEN Hub workbook shown in BLUE is Optional.

Dave

 

[DWRgt2885]

Hi Dave, thanks for looking into this. I'm getting a 'Type Mismatch' error when it runs, sometime it importsd, but sometimes it doesn't. Also CopyfromRange has headers i'd rather not import each time. I added a line to remove the Password on my Copy to sheet.

Sub RefreshFromHub(ByVal FileName As String, Optional ByVal Password As String)




    Dim wbHub As Workbook
    Dim CopyFromRange As Range, CopyToRange As Range
    
    On Error GoTo exitsub
    If Not Dir(FileName, vbDirectory) = vbNullString Then
    Application.ScreenUpdating = False
    Sheets("Order Status").Unprotect Password:="2885"
    Set CopyToRange = ThisWorkbook.Sheets("Order Status").Range("A1").End(xlDown).Offset(1, 0)
    
    Set wbHub = Application.Workbooks.Open(FileName, ReadOnly:=False) 'Password:=Password)
    
    Set CopyFromRange = wbHub.Sheets(1).UsedRange
    
    CopyFromRange.Copy CopyToRange
    CopyToRange.CurrentRegion.EntireColumn.AutoFit
    
    wbHub.Close False
    
    Else
     Err.Raise 53
    End If
    
    Set wbHub = Nothing
    
exitsub:
    If Not wbHub Is Nothing Then wbHub.Close False
    Application.ScreenUpdating = True
    If Err > 0 Then MsgBox (Error(Err)), 64, "Error"
End Sub

 

[dmt32]

Hi,
see if this update does what you want

Sub RefreshFromHub(ByVal FileName As String, Optional ByVal wbPassword As String)


    Dim wbHub As Workbook
    Dim wsOrderStatus As Worksheet
    Dim CopyFromRange As Range, CopyToRange As Range
    
    Const wsPassword As String = "2885"
    
    On Error GoTo exitsub
    
    Set wsOrderStatus = ThisWorkbook.Sheets("Order Status")
    
    If Not Dir(FileName, vbDirectory) = vbNullString Then
    Application.ScreenUpdating = False
    
    
    With wsOrderStatus
        .Unprotect Password:=wsPassword
        Set CopyToRange = .Range("A1").End(xlDown).Offset(1, 0)
    End With
    
    Set wbHub = Application.Workbooks.Open(FileName, ReadOnly:=True, Password:=wbPassword)
    
    With wbHub.Sheets(1).UsedRange
        Set CopyFromRange = .Offset(1, 0).Resize(.Rows.Count - 1)
    End With
    
    CopyFromRange.Copy CopyToRange
    CopyToRange.CurrentRegion.EntireColumn.AutoFit
    
    wbHub.Close False
    
    Else
     Err.Raise 53
    End If
    
    Set wbHub = Nothing
    
exitsub:
    If Not wbHub Is Nothing Then wbHub.Close False
    wsOrderStatus.Protect Password:=wsPassword
    Application.ScreenUpdating = True
    If Err > 0 Then MsgBox (Error(Err)), 64, "Error"
End Sub

The workbook open password is OPTIONAL just omit it when calling procedure if not required

example:

RefreshFromHub "P:\Folder1\Folder2\Hub.xlsx"

Dave

 

[DWRgt2885]

Hi Dave,
Thanks again for this, it is working, but i still get the Type Mismatch. I looked into it, and i'm thinking it may be because i'm trying to convert a date. I have a few lines of code in certain text boxes that apply a date format "after update" other wiose, this does exactly what I was looking for, thank you kindly sir!

 

[DWRgt2885]

This Type Mismatch error is quite the enigma.

 

[dmt32]

This Type Mismatch error is quite the enigma.

You need to pass the FileName as a string if this is where the error occurs?

If not, post code you are calling procedure with.

Dave

 

[DWRgt2885]

I can't seem to figure out where the errors is occurring. When this is called it is written exactly as below. how do i pass as string as you wrote?

RefreshFromHub "P:\Folder1\Folder2\Hub.xlsx"

 

[dmt32]

That's the code I gave as an example - helpful to see all your code you are calling the procedure from.

Dave

 

[DWRgt2885]

Hi Dave,
I have it in the workbook_Open event.

Private Sub Workbook_Open()
Dim iRow As Long
Dim WS As Worksheet


    Set WS = Worksheets("Order Status")
    strPwd = "2885"
     Application.ScreenUpdating = False
     Application.DisplayAlerts = False
     With ActiveSheet
    .Protect Password:=strPwd
    On Error Resume Next
    .ShowAllData
    .Protect _
        Contents:=True, _
        AllowFiltering:=True, _
        userinterfaceonly:=True, _
        Password:=strPwd
        
End With
      
    frmOrders.Show


    'Update Workbook with HUB DATA
    RefreshFromHub "C:\Users\DReardon\Desktop\Hub Folder\HUB.xlsm"
    UpdateData


Application.Visible = True
End Sub