How to move All Data Without Clearing the table

[adam]

Hi Anyone,

In my excel workbook with the name of “Product”, I have two sheets sheet1 (which I have named as “INPUT”) and sheet2 (which I have named as “DATA”).

I have a macro in Sheet1 which when clicked will move the data in column A16:A25 to Sheet2’s Column C15 and so on.

And as same way, the data in column B16:B25 will be moved to Sheet2’s Column D15 and so on.

I also want the serial number in D3 & date in D4 to be moved to A15 and B15

I want the table in sheet2 to be filled as follows

Date Serial Code Qty
3/3/2010 0001 1 2
3/3/2010 0001 2 9
3/3/2010 0001 3 2
3/3/2010 0001 4 8
3/3/2010 0001 5 2
3/3/2010 0002 4 5
3/3/2010 0002 6 1
3/3/2010 0002 8 3
3/3/2010 0002 1 3
3/3/2010 0002 9 2

I have tried many ways to make the code as above.

I would be pleased if you could help me with above.

But my code could only work the columns C & D to work in sheet2. And also when I move the data from sheet1 to sheet2 the table in sheet1 clears away. I don’t want that to happen.

Thanks in advanced.

I have attached the file for your reference

Regards
Adam

[HansV]

I take it that you got this code from somewhere or someone else.
There are several lines marked "optional". These clear ranges on the Input sheet after they have been copied to the Data sheet.
If you only want to clear the contents and leave the cell borders, change .Clear to .ClearContents in these lines.
If you don't want to clear the ranges at all, remove or comment out the lines marked with "optional".

The code can be simplified to:

Code: Select all

Sub CopyToDATA()
  Dim r As Long
  ActiveSheet.[D3] = Sheet2.[D3].Value + 1
  r = Sheets("Data").Range("C" & Sheets("Data").Rows.Count).End(xlUp).Row + 1
  Sheets("Input").Range("A16:B25").Copy Destination:=Sheets("Data").Range("C" & r)
  Sheets("Input").Range("D3").Copy Destination:=Sheets("Data").Range("B" & r & ":B" & (r + 9))
  Sheets("Input").Range("D4").Copy Destination:=Sheets("Data").Range("A" & r & ":A" & (r + 9))
End Sub

[adam]

Hi Hans,
After I have used Your Code, the contents in the sheet1 on does not get cleared. & also the serial number in sheet1 changes to 0001 even if I change the number to 0002. when I click the UpdateLog Button the serial number in sheet2 always remains as 0001. But I could change the date.

Could you explain pls?

Regards
Adam

[HansV]

See the remarks in my previous reply about clearing data. I thought you didn't want to do that, but if you do, you can reinsert those lines.

[adam]

Here is how I modified your code.
Sub CopyToDATA()
Dim r As Long
ActiveSheet.[D3] = Sheet2.[D3].Value + 1
r = Sheets("Data").Range("C" & Sheets("Data").Rows.Count).End(xlUp).Row + 1
Sheets("Input").Range("A16:B25").Copy Destination:=Sheets("Data").Range("C" & r)
Sheets("Input").Range("A16:B25").ClearContents 'optional; ClearContents for next entry
Sheets("Input").Range("D3").Copy Destination:=Sheets("Data").Range("B" & r & ":B" & (r + 9))
Sheets("Input").Range("D3").ClearContents 'optional; ClearContents for next entry
Sheets("Input").Range("D4").Copy Destination:=Sheets("Data").Range("A" & r & ":A" & (r + 9))
Sheets("Input").Range("D4").ClearContents 'optional; ClearContents for next entry
End Sub

with this modification the contents are cleared as they are copied to sheet2. But still the copied serial number to sheet2 remains as 0001 even when I change the serial in sheet1 to 0002.

Also suppose in the given range I do not fill all the fields A16:A25 & B16:25. I want the serial Numbers and date to be filled into the cells of sheet2 with that of the fields I fill from the ranges A16:A25 & B16:B25 in sheet1

Thanks in advance
Adam

[adam]

Hi Hans,

When I press the Update Log Button in Sheet1, I want the serial number in sheet1 to be changed sequentially to the next number and the existing number to be moved to sheet2 along with other entries from sheet1.

And also when I fill entries with only half of the given range in sheet1 I want the date & serial Numbers to be filled in Sheet2 with only for those rows that I have filled in Sheet1.

Your help would be greatly appreciated.

Thanks in Advance.

Regards
Adam

[HansV]

I'm not entirely sure what you want exactly, but try this:

Code: Select all

Sub CopyToDATA()
  Dim r As Long
  Dim m As Long
  Dim n As Long
  m = Sheets("Input").Range("A" & Sheets("Input").Rows.Count).End(xlUp).Row
  If m = 15 Then
    MsgBox "No data", vbExclamation
    Exit Sub
  End If
  r = Sheets("Data").Range("C" & Sheets("Data").Rows.Count).End(xlUp).Row + 1
  With Sheets("Input").Range("A16:B" & m)
    .Copy Destination:=Sheets("Data").Range("C" & r)
    .ClearContents
  End With
  Sheets("Data").Range("B" & r & ":B" & (r + m - 16)) = Sheets("Input").Range("D3")
  With Sheets("Input").Range("D3")
    .Value = .Value + 1
  End With
  With Sheets("Input").Range("D4")
    .Copy Destination:=Sheets("Data").Range("A" & r & ":A" & (r + m - 16))
    .ClearContents
  End With
  Sheets("Data").Range("A15:D15").Copy
  Sheets("Data").Range("A" & r & ":B" & (r + m - 16)).PasteSpecial Paste:=xlPasteFormats
  Application.CutCopyMode = False
End Sub

See the attached version.

Product2.xlsm

[adam]

Its what I wanted & it works fine.
Thanks Hans. I really appreciate it.

Cheers
Adam

[adam]

Hi Hans,
I have modified the table that I have in Sheet1. I have also modified the Table in Sheet2. I have applied Vlookup formula to the columns C, F & H in sheet1.
And also I have applied Vlookup Formulas to the columns D,E,F in sheet2.

I have changed the column where I want to put the data in input Sheet. Now I want to copy the data from input sheet A16:A25 & I16:I25 into Column C & Column G of Data Sheet. along with the rest of the columns.

I want to start from the 5th row in data Sheet. I tried modifying the Code. But i'm getting some errors.
I would be pleased if you could help me with this modification.

Thanks in advance.

I’ve attached the file for your reference

Regards
Adam

[HansV]

Try this version:

Code: Select all

Sub CopyToDATA()
  Dim r As Long
  Dim m As Long
  Dim n As Long
  ' Use column C because column A contains "TOATL" (and B is empty)
  m = Sheets("NewMemo").Range("C" & Sheets("NewMemo").Rows.Count).End(xlUp).Row
  ' Headers are now in row 4
  If m = 4 Then
    MsgBox "No data", vbExclamation
    Exit Sub
  End If

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

  Sheets("NewMemo").Range("A16:A" & m & ",I16:I" & m & ",H12").ClearContents

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

[adam]

Hi Hans,
your modified code suits my needs.

but its showing the Order Sheet; date and serial rows to the ranges that I haven't Filled in NewMemo sheet.

For example if I fill the first Row in the given Range, Say A16 in NewMemo sheet it fills the Order data sheet with 10 rows of the date & the Serial Number. It does not minimize the date And Serial number to the rows that I have filled in sheet1

How could this be Overcome.

Regards
Adam

[HansV]

Sorry, I overlooked the fact that column C on the NewMemo sheet contains formulas. Change the line

Code: Select all

  m = Sheets("NewMemo").Range("C" & Sheets("NewMemo").Rows.Count).End(xlUp).Row

to

Code: Select all

  m = Sheets("NewMemo").Range("I" & Sheets("NewMemo").Rows.Count).End(xlUp).Row

[adam]

Thanks Hans!
It really works. You're Great

[adam]

Hi Hans,

I have created a New sheet in the attached workbook with the name of "memos".

After clicking the Upload Log Button I want the fields Highlighted in "Yellow" in the NewMemo Sheet to be copied into the memos Sheet & the fields that are entered into the table in the memos sheet to be copied into orders sheet.

In short; to combine the two codes into One Code so that when the update log button is clicked the contents in the fields of sheet1 gets copied to their respective fields in OrderData Sheet & Memos Sheet.

Here is the code which Moves the highlighted fields into Memos Sheet
I have added a code to stop screen flickring or vibrating when I run the macro. it is Application.ScreenUpdating = False

I also want the code to save the workbook after the macro Update Log Button is run.

Thanks in advance

Sub UpdateLogWorksheet()
Application.ScreenUpdating = False

Dim MemosWks As Worksheet
Dim NewMemoWks 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")

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

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

And below is the code that you have provided to copy the fields in the table to OrderData Sheet

Sub CopyToDATA()
Dim r As Long
Dim m As Long
Dim n As Long
' Use column C because column A contains "TOATL" (and B is empty)
m = Sheets("NewMemo").Range("I" & Sheets("NewMemo").Rows.Count).End(xlUp).Row
' Headers are now in row 4
If m = 4 Then
MsgBox "No data", vbExclamation
Exit Sub
End If

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

Sheets("NewMemo").Range("A16:A" & m & ",I16:I" & m & ",H12").ClearContents

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

Regards
Adam

[HansV]

You can create a macro that calls both and saves the workbook:

Code: Select all

Sub RunBothMacros
  Call UpdateLogWorksheet
  Call CopyToDATA
  ActiveWorkbook.Save
End Sub

While testing, always make a backup copy first, so that you still have the previous version if something goes wrong!

[adam]

it does not work in that way Hans. When the macro is clicked. The date and serial numbers are not copied form the NewMemo Sheet. And also the Serial Remains to 0001 like previously.

Wont both codes be pasted in one module. So that it would not be needed to add more modules.
in the workbook I had sent to you I had written TOATL in the TOTAL column in NewMemo Sheet. and because of that you have written in your code TOTAL as TOATL. I have changed that to total.

Pls tell me how to woek the macro simultaneously with two codes.

regards
Adam

[HansV]

The two macros don't need to be in separate modules; you can move them into the same module. You could even move the code of one of the macros into the other one.

[adam]

I have modified the code by pasting both codes in one module. I have removed the End Sub from Sub CopyToDATA() Macro. to this I have added the Updatelod Macro. after filling all the fields in the NewMemo Sheet when I click the macro I see a message box saying Fill All the fields even when all the fields are filled. and the data in the fields related to the memos sheet does not get copied. instead oly the fields in the table gets copied to the orderdata sheet.

I have tried a lot to overcome this. But couldn't solve out.

Could you help me pls.

The code I have modified is as follows

Sub CopyToDATA()
Application.ScreenUpdating = False
Dim r As Long
Dim m As Long
Dim n As Long
' Use column C because column A contains "TOTAL" (and B is empty)
m = Sheets("NewMemo").Range("I" & Sheets("NewMemo").Rows.Count).End(xlUp).Row
' Headers are now in row 4
If m = 4 Then
MsgBox "No data", vbExclamation
Exit Sub
End If

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

Sheets("NewMemo").Range("A16:A" & m & ",I16:I" & m & ",H12").ClearContents

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

Dim MemosWks As Worksheet
Dim NewMemoWks 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")

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

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

Regards
Adam

[HansV]

The line that clears the data should be moved down, and the cell with the serial number should not be cleared.

The following may not do exactly what you wish, but you should now be able to modify it further.

Code: Select all

Sub CopyToDATA()
  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 "TOATL" (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
End Sub

[adam]

It works Finally.
Thanks Hans