Copy Data from my current active workbook to a closed workbook

M

Martin sherk

Board Regular
Joined
Sep 11, 2022
Messages
94
Office Version
  1. 365
  2. 2016
Hello,

I need help copying data from my current active workbook(Code is in another workbook) to a closed file

My current active worksheet which I will copy data from has the name "Customers Data" sheet

My destination path for the closed workbook is C:\1.Martin\1.Work\Customers\October 2022
My destination workbook is: Customer Raw data.xlsx
My destination worksheet is: Customers Data

Can someone help construct a VBA to do the above, I will be thankful.
 
Sort by date Sort by votes
Martin sherk said:
It worked Flawlessly !! time saved thanks to you.

one last request please, it copies data to the destination file but after row 1000, the data copied is without table format, can i fix that?
Click to expand...

replace existing code with these two codes

VBA Code: 
Sub SubmitData()
    Dim FullName            As String
    Dim wsCustomersData     As Worksheet, wsCustomerMainData As Worksheet
    Dim wbCustomerRawData   As Workbook
    Dim CopyFromRange       As Range, CopyToRange As Range
    
    Const FilePath As String = "C:\1.Martin\1.Work\Customers\October 2022\"
   
    Const FileName  As String = "Customer Raw data.xlsx"
    
    FullName = FilePath & FileName
    
    Set wsCustomersData = ThisWorkbook.Worksheets("Customers Data")
    'size the copy range (sheet must not be protected)
    Set CopyFromRange = wsCustomersData.Range("A1").CurrentRegion
    
    On Error GoTo myerror
    If Not Dir(FullName, vbDirectory) = vbNullString Then
        Application.ScreenUpdating = False
        Set wbCustomerRawData = Workbooks.Open(FullName, 0, False)
        Set wsCustomerMainData = wbCustomerRawData.Worksheets("Customer Main Data")
        'size to destination range
        Set CopyToRange = wsCustomerMainData.Cells(1, 1).Resize(, CopyFromRange.Columns.Count)
        
        'ensure header values match
        CopyToRange.Value = CopyFromRange.Rows(1).Value
        
        'copy data to sheet
        CopyFromRange.AdvancedFilter Action:=xlFilterCopy, _
        CopyToRange:=CopyToRange
        
    Else
        'file not found
        Err.Raise 53
    End If
    
    ColorBanding wsCustomerMainData.UsedRange
    
myerror:
    'close & if no error, save file
    If Not wbCustomerRawData Is Nothing Then wbCustomerRawData.Close CBool(Err = 0)
    Application.ScreenUpdating = True
    'inform user
    If Err <> 0 Then MsgBox (Error(Err)), 48, "Error"
    
End Sub

Sub ColorBanding(ByVal Target As Range)
   Dim r As Range
   For Each r In Target.Rows
     r.Interior.Color = IIf(r.Row Mod 2 <> 0, 15189684, 15917529)
   Next r
   'header row
   Target.Rows(1).Interior.Color = 12874308
End Sub

Dave
 
Upvote 0

Excel Facts

Format cells as date
Select range and press Ctrl+Shift+3 to format cells as date. (Shift 3 is the # sign which sort of looks like a small calendar).
dmt32 said:
replace existing code with these two codes

VBA Code: 
Sub SubmitData()
    Dim FullName            As String
    Dim wsCustomersData     As Worksheet, wsCustomerMainData As Worksheet
    Dim wbCustomerRawData   As Workbook
    Dim CopyFromRange       As Range, CopyToRange As Range
   
    Const FilePath As String = "C:\1.Martin\1.Work\Customers\October 2022\"
  
    Const FileName  As String = "Customer Raw data.xlsx"
   
    FullName = FilePath & FileName
   
    Set wsCustomersData = ThisWorkbook.Worksheets("Customers Data")
    'size the copy range (sheet must not be protected)
    Set CopyFromRange = wsCustomersData.Range("A1").CurrentRegion
   
    On Error GoTo myerror
    If Not Dir(FullName, vbDirectory) = vbNullString Then
        Application.ScreenUpdating = False
        Set wbCustomerRawData = Workbooks.Open(FullName, 0, False)
        Set wsCustomerMainData = wbCustomerRawData.Worksheets("Customer Main Data")
        'size to destination range
        Set CopyToRange = wsCustomerMainData.Cells(1, 1).Resize(, CopyFromRange.Columns.Count)
       
        'ensure header values match
        CopyToRange.Value = CopyFromRange.Rows(1).Value
       
        'copy data to sheet
        CopyFromRange.AdvancedFilter Action:=xlFilterCopy, _
        CopyToRange:=CopyToRange
       
    Else
        'file not found
        Err.Raise 53
    End If
   
    ColorBanding wsCustomerMainData.UsedRange
   
myerror:
    'close & if no error, save file
    If Not wbCustomerRawData Is Nothing Then wbCustomerRawData.Close CBool(Err = 0)
    Application.ScreenUpdating = True
    'inform user
    If Err <> 0 Then MsgBox (Error(Err)), 48, "Error"
   
End Sub

Sub ColorBanding(ByVal Target As Range)
   Dim r As Range
   For Each r In Target.Rows
     r.Interior.Color = IIf(r.Row Mod 2 <> 0, 15189684, 15917529)
   Next r
   'header row
   Target.Rows(1).Interior.Color = 12874308
End Sub

Dave
Click to expand...
Hey Dave,

i ran the above code and had the below error
1667063232901.png
 
Upvote 0
curious, can you comment out the on error statement & let me know where error occurs

VBA Code: 
On Error GoTo myerror ' < turn this off

Dave
 
Upvote 0
dmt32 said:
curious, can you comment out the on error statement & let me know where error occurs

VBA Code: 
On Error GoTo myerror ' < turn this off

Dave
Click to expand...
yes sir,

in the below code:
VBA Code: 
     CopyFromRange.AdvancedFilter Action:=xlFilterCopy, _
        CopyToRange:=CopyToRange

1667066014328.png
 
Upvote 0
have you protected the worksheet?

Dave
 
Upvote 0
Martin sherk said:
i didn't, is there a way to avoid doing this step. as I will give the code to my employees and I need it to run automatically with no intervention from their side?
Click to expand...

As 1st version was working ok go back to that & I will have a look at this in morning

Dave
 
Upvote 0
dmt32 said:
As 1st version was working ok go back to that & I will have a look at this in morning

Dave
Click to expand...
yes, it was working great, it's only I want to copy them as a table.

Thanks, Dave, I really appreciate your time and support.
 
Upvote 0
Hi,
I have not been able to recreate the error but try following I have made some minor changes to & see if resolves

VBA Code: 
Sub SubmitData()
    Dim FullName            As String
    Dim wsCustomersData     As Worksheet, wsCustomerMainData As Worksheet
    Dim wbCustomerRawData   As Workbook
    Dim rngCopyFrom         As Range, rngCopyTo As Range
    
'-------------------------------------------------------------------------------------
'                                       Settings
'-------------------------------------------------------------------------------------
    Const FilePath As String = "C:\1.Martin\1.Work\Customers\October 2022\"
    
    Const FileName  As String = "Customer Raw data.xlsx"
'-------------------------------------------------------------------------------------
    
    FullName = FilePath & FileName
    
    Set wsCustomersData = ThisWorkbook.Worksheets("Customers Data")
    'size the copy range (sheet must not be protected)
    Set rngCopyFrom = wsCustomersData.Range("A1").CurrentRegion
    
    On Error GoTo myerror
    If Not Dir(FullName, vbDirectory) = vbNullString Then
        Application.ScreenUpdating = False
        Set wbCustomerRawData = Workbooks.Open(FullName, 0, False)
        Set wsCustomerMainData = wbCustomerRawData.Worksheets("Customer Main Data")
        'clear existing data
        wsCustomerMainData.UsedRange.Offset(1).Clear
        'size to destination range
        Set rngCopyTo = wsCustomerMainData.Cells(1, 1).Resize(, rngCopyFrom.Columns.Count)
        'copy header values
        rngCopyTo.Value = rngCopyFrom.Rows(1).Value
        'copy data to customer sheet
        rngCopyFrom.AdvancedFilter Action:=xlFilterCopy, CopyToRange:=rngCopyTo
        
    Else
        'file not found
        Err.Raise 53
    End If
    
    ColorBanding wsCustomerMainData.UsedRange
    
myerror:
    'close & if no error, save file
    If Not wbCustomerRawData Is Nothing Then wbCustomerRawData.Close CBool(Err = 0)
    Application.ScreenUpdating = True
    'inform user
    If Err <> 0 Then MsgBox (Error(Err)), 48, "Error"
    
End Sub

Sub ColorBanding(ByVal Target As Range)
   Dim r As Range
   
'--------------------------------------------------------------------
'                          Banding Colours
'--------------------------------------------------------------------
   Const OddRows As Long = 15189684, EvenRows As Long = 15917529
   Const HeaderRow As Long = 12874308
'--------------------------------------------------------------------

   For Each r In Target.Rows
     r.Interior.Color = IIf(r.Row Mod 2 <> 0, OddRows, EvenRows)
   Next r
   'header row
   Target.Rows(1).Interior.Color = HeaderRow
   
End Sub
 
Upvote 0
Hello Dave,

May you please help me with the below error:
VBA Code: 
 Set rngCopyTo = wsCustomerMainData.Cells(1, 1).Resize(, rngCopyFrom.Columns.Count)

1667152721297.png


Also please note that the destination file is .XLSM
 
Upvote 0
You must log in or register to reply here.

Similar threads

J
  • Question
Run time error with VBA to copy Chart objects from closed workbook
Replies
4
Views
115
Domenic
D
KlausW
  • Solved
copy data from several closed workbooks to one workbook.
Replies
5
Views
697
KlausW
KlausW
R
  • Question
VBA to pull data from closed workbooks
Replies
3
Views
490
Logit
Logit
R
  • Question
VBA to Copy Multiple sheets to new workbook & save as .xlsb or .xlsx
2
Replies
16
Views
694
rahildhody
R
I
  • Question
VBA - Copy Sheet from a workbook saved as a date - paste to specifically named sheet in another workbook based on the date
Replies
2
Views
225
Insurance Dave
I

Forum statistics

Threads
1,214,929
Messages
6,122,317
Members
449,081
Latest member
tanurai

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top