Copy Data To New Workbook & Save

[adam]

Hi anyone,

The code posted at the Post=12526 (by me) saves the data to the sheets named in the code to the active workbook itself.
As Excel’s file size increases on each data entry, my intention is to separate the worksheets where data gets updated daily to another workbook.

Meaning; to remove the sheets named in the code from the active workbook and to save the data to the sheets of the workbook with the name “Database”.
The location of the workbook with the name “Database” in my PC is in the D drive inside the folder “Software”

I have tried by adding the line Set wb = Database. But it seems to be out of context.

D:\Software

Any suggestion regarding this would be kindly appreciated.

[HansV]

You have to open the workbook in Excel. You can use the following lines of code for that:

Dim wb As Workbook
Set wb = Workbooks.Open("D:\Software\Database.xlsx")

Change .xlsx to .xlsm if the workbook contains macros, or to .xlsb if you have saved it as a binary workbook.

[adam]

Even though the suggested lines is applied, the code still copies data to the workbook where the code is originating. The sheet "NewMemo" lies in the workbook where the code resides. But the other two sheets OrderData & Memos are in workbook Database.

The line Dim wb As Workbook is placed above the line Dim MemosWks As Worksheet
& the line Set wb = Workbooks.Open("D:\Software\Database.xlsx") s placed above the line Set NewMemoWks = Worksheets("NewMemo")

What have I misunderstood here?

[HansV]

Just opening a workbook does not mean that the code will automatically write to it. If you want to refer to sheets in the Database workbook, you can do it like this:

Dim OrderDataWks As Worksheet
Set OrderDataWks = wb.Worksheets("OrderData")

If you then use a line such as

OrderDataWks.Range("A1") = "Jones"

the value Jones will be stored in cell A1 on the OrderData sheet in the Database workbook.

[adam]

Thank you Hans. It works now. But there’s a problem in doing so. When I try to save the data for the second time after my initial save, I get a message that the workbook database is already open and that if press Ok I’ll lose my data.

This indicates that the workbook database is opening each time I run the macro, leading me to close the work book database each time I make a new save.

How could I overcome this? Can’t the data be saved in closed condition of the workbook database?

[HansV]

You can't save data in a closed workbook. You have several options:

1. Close the Database workbook when you're done with it:

Code: Select all

Dim wb As Workbook
' Open the workbook
Set wb = Workbooks.Open("D:\Software\Database.xlsx")
' Save some values in the workbook
...
...
' Save and close the workbook
wb.Close SaveChanges:=True

2. Check whether the workbook is already open:

Code: Select all

Dim wb As Workbook
' Temporarily suppress error messages
On Error Resume Next
' Try to refer to the workbook
Set wb = Workbooks("Database.xlsx")
' Show error messages again
On Error GoTo 0
' If the workbook was not open, wb will be Nothing
If wb Is Nothing Then
  ' So open the workbook
  Set wb = Workbooks.Open("D:\Software\Database.xlsx")
End If
' Save some values to the workbook
...
...

You could also open the Database workbook simultaneously with the other one, and keep it open.

[adam]

Once again thanks Hans. I have used your option one which opens the workbook and closes after saving the data.

[adam]

By the way, when I run the macro the workbook database opens and visualizes the sheet where the data gets saved to. This lets the user know that he is saving data by opening a closed workbook and again closing it back after saving data.

How could I let the user not know that the data is being saved to another workbook.

Can the addition of the lines Application.ScreenUpdating = False to the workbook Database would be of any help?

Any suggestion regarding this would be kindly appreciated.

[HansV]

Yes, I'd add the line

Application.ScreenUpdating = False

before opening the other workbook, and

Application.ScreenUpdating = True

after you have closed it.

[ABabeNChrist]

How could I let the user not know that the data is being saved to another workbook.

Just a thought
You can also add a MsgBox, this will also let the user know data is being saved to another workbook

[HansV]

But Adam's question was "How could I let the user not know that the data is being saved to another workbook"...

[ABabeNChrist]

Opps my bad

[adam]

Should I place it as

Code: Select all

Private Sub Workbook_Activate()
Application.ScreenUpdating = False
End Sub

Private Sub Workbook_Deactivate()
Application.ScreenUpdating = True
End Sub

In the ThisWorkbook module of the Database workbook? If not, any suggestion on this would be kindly appreciated.

[HansV]

No, in the code that opens/closes the Database workbook.

[adam]

Here is my final code that opens the workbook database and closes after saving data to it. I had initially applied the screening update lines to the code. But its not making any difference.

The user can still see the workbook database opening and closing.

What may be the reason for this?

Code: Select all

Sub CopyToDATA()
Application.ScreenUpdating = False

  Dim r As Long
  Dim m As Long
  Dim n As Long
 
  Dim wb As Workbook
  Dim MemosWks As Worksheet
  Dim NewMemoWks As Worksheet
  Dim OrderWks As Worksheet
  
  Dim nextRow As Long
  Dim oCol As Long

  Dim myRng As Range
  Dim myCopy As String
  Dim myCell As Range
  

  'cells to copy from NewMemo sheet - some contain formulas
  myCopy = "D3,D8,H8,H9,H12,H13,J9,J12,J13,J36,J8,H7,J7,D7"

  Set NewMemoWks = Worksheets("NewMemo")
  Set wb = Workbooks.Open("D:\Software\Database.xlsx")
  Set MemosWks = wb.Worksheets("Memos")
  Set OrderWks = wb.Worksheets("OrderData")
  
    With NewMemoWks
    Set myRng = .Range(myCopy)
  
      If Application.CountA(myRng) <> myRng.Cells.Count Then
      MsgBox "Please fill in all the fields!"
      Exit Sub
    End If
  End With

  ' Use column C because column A contains "Total" (and B is empty)
  m = NewMemoWks.Range("I" & NewMemoWks.Rows.Count).End(xlUp).Row
  ' Headers are now in row 4
  If m = 15 Then
    MsgBox "No data", vbExclamation
    Exit Sub
  End If

  r = OrderWks.Range("C" & OrderWks.Rows.Count).End(xlUp).Row + 1
  ' Copy Code
  NewMemoWks.Range("A16:A" & m).Copy Destination:=OrderWks.Range("C" & r)
  ' Copy Quantity
  NewMemoWks.Range("I16:I" & m).Copy Destination:=OrderWks.Range("G" & r)
  ' Copy Category as values
  NewMemoWks.Range("C16:C" & m).Copy
  OrderWks.Range("D" & r & ":D" & (r + m - 16)).PasteSpecial Paste:=xlPasteValues
  ' Copy Description as values
  NewMemoWks.Range("F16:F" & m).Copy
  OrderWks.Range("E" & r & ":E" & (r + m - 16)).PasteSpecial Paste:=xlPasteValues
  ' Copy Rate as values
  NewMemoWks.Range("H16:H" & m).Copy
  OrderWks.Range("F" & r & ":F" & (r + m - 16)).PasteSpecial Paste:=xlPasteValues
  ' Copy Value as values
  NewMemoWks.Range("J16:J" & m).Copy
  OrderWks.Range("H" & r & ":H" & (r + m - 16)).PasteSpecial Paste:=xlPasteValues
  ' Copy Serial number
  OrderWks.Range("B" & r & ":B" & (r + m - 16)) = NewMemoWks.Range("D3")
  ' Copy Date
  NewMemoWks.Range("H12").Copy Destination:=OrderWks.Range("A" & r & ":A" & (r + m - 16))

  OrderWks.Range("A5:H5").Copy
  OrderWks.Range("A" & r & ":H" & (r + m - 16)).PasteSpecial Paste:=xlPasteFormats
  Application.CutCopyMode = False

  With MemosWks
    nextRow = .Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0).Row
  End With

  With MemosWks
    With .Cells(nextRow, "A")
      .Value = Now
      .NumberFormat = "hh:mm:ss"
    End With
    oCol = 2
    For Each myCell In myRng.Cells
      MemosWks.Cells(nextRow, oCol).Value = myCell.Value
      oCol = oCol + 1
    Next myCell
  End With

  With NewMemoWks.Range("D3")
    .Value = .Value + 1
  End With

  NewMemoWks.Range("A16:A" & m & ",I16:I" & m & ",D8,H8,H13,J8,J7,D7").ClearContents
  'clear input cells that contain constants
  With NewMemoWks
  On Error Resume Next
    With .Range("D8,H8,H9,H12,H13,J9,J13,J26,J8,F8,J7,D7").Cells.SpecialCells(xlCellTypeConstants)
     .ClearContents
      Application.GoTo .Cells(1) ', Scroll:=True
    End With
    On Error GoTo 0
  End With
  Call UnhideHideEmptyRowsFromPrevious
  wb.Close SaveChanges:=True
   Application.ScreenUpdating = True
End Sub

[HansV]

Turning ScreenUpdating off is not perfect.

You could hide the database workbook:
- Open it.
- Click Hide in the View tab of the ribbon.
- Quit Excel.
- You'll be asked if you want to save changes to the database workbook. Answer Yes.

Next time you open the workbook, it will be hidden.

[adam]

Thanks a lot Hans. Now I could save the data to database workbook without letting the user know.

[adam]

How could I change the following part of the code taken from post Post 21320so that it copies only the visible rows of the appropriate columns when the active sheet is in filter mode.

At present the code copies all the rows whether visible or hidden or filtered.

Anya help on this would be kindly appreciated.

Thanks in advance.

Code: Select all

r = OrderWks.Range("C" & OrderWks.Rows.Count).End(xlUp).Row + 1
  ' Copy Code
  NewMemoWks.Range("A16:A" & m).Copy Destination:=OrderWks.Range("C" & r)
  ' Copy Quantity
  NewMemoWks.Range("I16:I" & m).Copy Destination:=OrderWks.Range("G" & r)
  ' Copy Category as values
  NewMemoWks.Range("C16:C" & m).Copy
  OrderWks.Range("D" & r & ":D" & (r + m - 16)).PasteSpecial Paste:=xlPasteValues
  ' Copy Description as values
  NewMemoWks.Range("F16:F" & m).Copy
  OrderWks.Range("E" & r & ":E" & (r + m - 16)).PasteSpecial Paste:=xlPasteValues
  ' Copy Rate as values
  NewMemoWks.Range("H16:H" & m).Copy
  OrderWks.Range("F" & r & ":F" & (r + m - 16)).PasteSpecial Paste:=xlPasteValues
  ' Copy Value as values
  NewMemoWks.Range("J16:J" & m).Copy
  OrderWks.Range("H" & r & ":H" & (r + m - 16)).PasteSpecial Paste:=xlPasteValues
  ' Copy Serial number
  OrderWks.Range("B" & r & ":B" & (r + m - 16)) = NewMemoWks.Range("D3")
  ' Copy Date
  NewMemoWks.Range("H12").Copy Destination:=OrderWks.Range("A" & r & ":A" & (r + m - 16))

  OrderWks.Range("A5:H5").Copy
  OrderWks.Range("A" & r & ":H" & (r + m - 16)).PasteSpecial Paste:=xlPasteFormats
  Application.CutCopyMode = False