Simultaneous Movement of data

[adam]

Hi Hans,

The following VB code is applied to my worksheet named “NewMemo”.

The purpose if this code is for the simultaneous movement of data that is entered into the fields mentioned in the code, to the sheets named “OrderData” & “Memos”.

If one of the fields from the range ("D3,D8,H8,H9,H12,H13,J9,J12,J13,J26,J8,F8,J7") is not filled, a message box appears saying that “please fill all the fields”.

As a consequence of this, none of the data in the fields ("D3,D8,H8,H9,H12,H13,J9,J12,J13,J26,J8,F8,J7") gets copied or moved into the sheet “Memos”.

But the data within the range A16:A25 & I16:I25 gets copied into the sheet “OrderData”, Thus preventing the simultaneous movement of the data from ("D3,D8,H8,H9,H12,H13,J9,J12,J13,J26,J8,F8,J7") & (A16:A25 & I16:I25).

Since all the fields in the range ("D3,D8,H8,H9,H12,H13,J9,J12,J13,J26,J8,F8,J7") is mandatory to be filled, what I want from you is a modification of the existing code so that if one field from the range ("D3,D8,H8,H9,H12,H13,J9,J12,J13,J26,J8,F8,J7") is not filled, the data in the range (A16:A25 & I16:I25) should stay in the “NewMemo” sheet until the empty field from the data range ("D3,D8,H8,H9,H12,H13,J9,J12,J13,J26,J8,F8,J7") is filled.

Note:
It is not mandatory to fill the fields from the rangeA16:A25 & I16:I25. Data should be moved even if one field is filled from the range A16:A25 & I16:I25.

Your help in this would be greatly appreciated.

VB Code as mention above;

Code: Select all

Sub CopyToDATA()
On Error Resume Next
Application.ScreenUpdating = False

  Dim r As Long
  Dim m As Long
  Dim n As Long
 
  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,J26,J8,F8,J7"

  Set NewMemoWks = Worksheets("NewMemo")
  Set MemosWks = Worksheets("Memos")
  Set OrderWks = Worksheets("OrderData")

  ' 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 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

  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 & ",H12").ClearContents
  'clear input cells that contain constants
  With NewMemoWks
  On Error Resume Next
    With .Range("D8,H8,H9,H12,H13,J9,J12,J13,J26,J8,F8,J7").Cells.SpecialCells(xlCellTypeConstants)
     .ClearContents
      Application.GoTo .Cells(1) ', Scroll:=True
    End With
    On Error GoTo 0
  End With
   Application.ScreenUpdating = True
End Sub

Best Regards
Adam

[HansV]

Hi Adam.

I'll look into your question, but:
- Please don't direct your posts at me - others can answer your questions too.
- Please enclose long fragments of code in [code]...[/code] tags, this makes them easier to read.
- It would be nice if you provided some feedback to the replies you get, otherwise Loungers don't know if they helped.

[HansV]

The code that checks whether cells in the myCopy range are filled in, is

Code: Select all

  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

This block of code comes after the code that copies the values in A16:A25 and I16:I25. You should move the block of code up, so that it is executed before the values in A16:A25 and I16:I25 are copied.

[adam]

Hi Hans,

Oh! I'm sorry. It wont happen again.
If I'm not mistaken, I think I provide feedback to most of the replies I get.

Anyway, sorry if I didn't.

Regards,
Adam

[adam]

Hi Hans,

I'm Sorry I couldn't get what you had instructed. Where Should I paste the code. I mean above or below which line of the code.

I would be pleased if you could be more specific.

Thanks in advance.

Regards
Adam

[HansV]

Place it between the lines

Set OrderWks = Worksheets("OrderData")

and

' Use column C because column A contains "Total" (and B is empty)

[adam]

Thanks Hans for your kind help. It worked sweet and soft at the way Just I wanted it to be.

Thanks Once again.

Regards
Adam

[adam]

I hope you don't mind me posting back in this thread. Its just because my question is related with this thread I thought it would be easier to understand if I post in this thread.

My question is when I press the "Save & New" Button in the New Memo Sheet I want the fields D7, D8, F8, H8, H9,H13,J7 & J8 to be copied to the sheets "Memos" & cleared off from the "NewMemo" Sheet. But my code doesn't seem to be doing so. I would be happy if you could help me to sort out the problem. I tried finding the problem for myself. But couldn't succeed. Here's the code

Code: Select all

Sub CopyToDATA()
On Error Resume Next
Application.ScreenUpdating = False

  Dim r As Long
  Dim m As Long
  Dim n As Long
 
  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,J26,J8,F8,J7,D7"

  Set NewMemoWks = Worksheets("NewMemo")
  Set MemosWks = Worksheets("Memos")
  Set OrderWks = 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 & ",H12").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
   Application.ScreenUpdating = True
End Sub

[HansV]

You state that you want to copy cells

D7, D8, F8, H8, H9,H13,J7 & J8

but your code uses the list

myCopy = "D3,D8,H8,H9,H12,H13,J9,J12,J13,J26,J8,F8,J7,D7"

That list is quite a bit longer.

[adam]

Yeah you are right Hans.

I want to copy the codes D3,D8,H8,H9,H12,H13,J9,J12,J13,J26,J8,F8,J7,D7 to memos sheet and to get the ranges D7, D8, F8, H8, H9,H13,J7 & J8 cleared form the NewMemo sheet.

How could this be done.

[HansV]

Your code contains

Code: Select all

    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

As far as I can tell, the only thing you need to change is the list of cells to be cleared:

Code: Select all

    With .Range("D8,H8,H9,H13,J8,F8,J7,D7").Cells.SpecialCells(xlCellTypeConstants)
     .ClearContents
      Application.GoTo .Cells(1) ', Scroll:=True
    End With

[adam]

I got it Hans. Actually the following modification of the code clears the range that I want

Code: Select all

 NewMemoWks.Range("A16:A" & m & ",I16:I" & m & ",F8,D8,H8,H9,H13,J8,J7,D7").ClearContents
  'clear input cells that contain constants
  With NewMemoWks

But I wonder what the following line do then? I did replace the cell contents as you suggested but it didn't make any difference. It only works with the above modification

Code: Select all

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

[HansV]

Originally, you didn't want to clear cells containing formulas. Apparently, you now want to clear cells containing formulas too.

[adam]

The cells D9, D12, D13, D14, F12, H12, J9, J12,J13 contains formula I'm sorry, if I had provided wrong cell contents earlier.
Anyway, If this is the situation now; should I make any modification to the code?

[HansV]

In your previous reply, you wrote "Actually the following modification of the code clears the range that I want (...)". The range you mentioned there doesn't overlap with the cells containing formulas, so there's no need to change the code any further.

[adam]

Thanks for the suggestion, Hans.

By the way, one more thing If I may ask.

In the "PreviousMemo" Sheet of the same workbook I'm using the following code to fill the ranges mentioned in the code. When I write the serial number in the cell D3 rest of the corresponding cells get filled with appropriate data from "orders" sheet & "memos" sheet.

What I'm trying to tell is that when I protect the sheet by unlocking only the cell D3 and write the serial number I get debug message or the range A16:A25 & I16:I25 doesn't get filled. But when I unprotect the sheet and write the serial number in D3 the corresponding cells in the range A16:A25 & I16:I25 get filled. Following is the code I'm using

Code: Select all

Private Sub Worksheet_Change(ByVal Target As Range)
Application.ScreenUpdating = False
  Dim r As Long
  Dim m As Long
  Dim n As Long
  Dim wsh As Worksheet
  Dim lngSerial As Long
  If Not Intersect(Range("D3"), Target) Is Nothing Then
    Application.EnableEvents = False
    Range("A16:A25").ClearContents
    Range("I16:I25").ClearContents
    lngSerial = Range("D3")
    n = 15
    Set wsh = Worksheets("OrderData")
    m = wsh.Range("A" & wsh.Rows.Count).End(xlUp).Row
    For r = 5 To m
      If wsh.Range("B" & r) = lngSerial Then
        n = n + 1
        Range("A" & n) = wsh.Range("C" & r)
        Range("I" & n) = wsh.Range("G" & r)
      End If
    Next r
    Application.EnableEvents = True
End If
Application.ScreenUpdating = True
End Sub

What might be the cause for this?

[HansV]

You write that you only unlock D3, so I assume that A16:A25 and I16:I25 are still locked. But in a protected sheet, you can only modify unlocked cells, so you'll get an error message if you try to modify A16:A25 and/or I16:I25.

There are two ways to solve this problem:

1) Unprotect the sheet before you modify the cells, and protect it again afterwards:

Me.Unprotect
' Code to modify A16:A25 and I16:I25 goes here
...
Me.Protect

- or -

2) Protect the sheet using code, with UserInterfaceOnly:=True. That means that the sheet will be protected for interactive use, but not for VBA code. This is best done in the Workbook_Open event in the ThisWorkbook module:

Code: Select all

Private Sub Workbook_Open()
  Worksheets("PreviousMemo").Protect UserInterfaceOnly:=True
End Sub

[adam]

Thanks for the help Hans. I locked all the cells except the cell D3 & used your second option.
Finally it works the way as I wanted & I'm happy now.

[adam]

Following is a modification of the code I had posted at post 9171

Code: Select all

    Sub SaveNewMemo()
    On Error Resume Next
    Application.ScreenUpdating = False

      Dim r As Long
      Dim m As Long
      Dim n As Long

      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 = "O6,O9,O10,I9,M9,M10,M11,M12,O11,O12,O13,I13,O54"

      Set NewMemoWks = Worksheets("NewMemo")
      Set MemosWks = Worksheets("MemoDetails")
      Set OrderWks = Worksheets("Data")
     
        With NewMemoWks
        Set myRng = .Range(myCopy)
     
          If Application.CountA(myRng) <> myRng.Cells.Count Then
          MsgBox "Please fill in all the fields!", vbExclamation, " Version 1.0"
          Exit Sub
        End If
      End With

      ' Use column N because column F contains "Line Total" (and L is empty)
      m = NewMemoWks.Range("N" & NewMemoWks.Rows.Count).End(xlUp).Row
      ' Headers in Data Sheet are now in row 4
      If m = 17 Then
        MsgBox "No data", vbExclamation
        Exit Sub
      End If

      r = OrderWks.Range("D" & OrderWks.Rows.Count).End(xlUp).Row + 1
     
      ' Copy Code
      NewMemoWks.Range("F18:F" & m).Copy Destination:=OrderWks.Range("D" & r)
     
      ' Copy Rate
       NewMemoWks.Range("N18:N" & m).Copy
      OrderWks.Range("G" & r & ":G" & (r + m - 18)).PasteSpecial Paste:=xlPasteValues
     
      ' Copy Category as values
      NewMemoWks.Range("H18:H" & m).Copy
      OrderWks.Range("E" & r & ":E" & (r + m - 18)).PasteSpecial Paste:=xlPasteValues
     
      ' Copy Description as values
      NewMemoWks.Range("K18:K" & m).Copy
      OrderWks.Range("F" & r & ":F" & (r + m - 18)).PasteSpecial Paste:=xlPasteValues

      ' Copy Line Total as values
      NewMemoWks.Range("O18:O" & m).Copy
      OrderWks.Range("H" & r & ":H" & (r + m - 18)).PasteSpecial Paste:=xlPasteValues
     
      ' Copy Serial number
      OrderWks.Range("B" & r & ":B" & (r + m - 18)) = NewMemoWks.Range("O6")
     
      ' Copy Date
      NewMemoWks.Range("O11").Copy
      OrderWks.Range("A" & r & ":A" & (r + m - 18)).PasteSpecial Paste:=xlPasteValues

    ' Copy Location
      OrderWks.Range("I" & r & ":I" & (r + m - 18)) = NewMemoWks.Range("M10")
     
      ' Copy Accession
      OrderWks.Range("C" & r & ":C" & (r + m - 18)) = NewMemoWks.Range("O9")
     
      OrderWks.Range("A5:I5").Copy
      OrderWks.Range("A" & r & ":I" & (r + m - 18)).PasteSpecial Paste:=xlPasteFormats
      Application.CutCopyMode = False

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

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

      With NewMemoWks.Range("O6")
        .Value = .Value + 1
      End With
      With NewMemoWks.Range("O9")
        .Value = .Value + 1
      End With
      NewMemoWks.Range("F18:F" & m & ",I9,M9:M12,O13").ClearContents
      'clear input cells that contain constants
      With NewMemoWks
      On Error Resume Next
        With .Range("I9,M9:M12,O13").Cells.SpecialCells(xlCellTypeConstants)
         .ClearContents
          Application.GoTo .Cells(1) ', Scroll:=True
        End With
        On Error GoTo 0
      End With
    ' Call UnhideHideEmptyRowsFromNewMemo
    ' Call SplitText
      'ThisWorkbook.Save
       Application.ScreenUpdating = True
    End Sub

In post 12537 I did ask you about the purpose of the part;

Code: Select all

With .Range("I9,M9:M12,O13").Cells.SpecialCells(xlCellTypeConstants)
     .ClearContents
      Application.GoTo .Cells(1) ', Scroll:=True
    End With

When the part;

Code: Select all

  NewMemoWks.Range("F18:F" & m & ",I9,M9:M12,O13").ClearContents
  'clear input cells that contain constants
  With NewMemoWks

was present in the code.

With your reply from post 12538, I knew that the second part was to clear the cell contents with formulas and the first part was to clear the cells without formulas.

Having this in mind I want to remove the part;

Code: Select all

With .Range("I9,M9:M12,O13").Cells.SpecialCells(xlCellTypeConstants)
     .ClearContents

so that the code would clear the range mentioned in;

Code: Select all

 NewMemoWks.Range("F18:F" & m & ",I9,M9:M12,O13").ClearContents

Because I have a feeling that the same thing about "clearing ranges" is repeated in the code.

I would be glad if you could help me to spot any compilation errors in this code.

Any help on this would be kindly appreciated.

Please Note: in columns H, K, N, O and cells I10:I13, M13, O10:O12 & O54 I have formula.

Thanks in advance.

[HansV]

You can remove the block of code

Code: Select all

      'clear input cells that contain constants
      With NewMemoWks
      On Error Resume Next
        With .Range("I9,M9:M12,O13").Cells.SpecialCells(xlCellTypeConstants)
         .ClearContents
          Application.GoTo .Cells(1) ', Scroll:=True
        End With
        On Error GoTo 0
      End With

since the cells I9,M9:M12,O13 have already been cleared above that in the line

Code: Select all

      NewMemoWks.Range("F18:F" & m & ",I9,M9:M12,O13").ClearContents