• Hi All

    Please note that at the Chandoo.org Forums there is Zero Tolerance to Spam

    Post Spam and you Will Be Deleted as a User

    Hui...

  • When starting a new post, to receive a quicker and more targeted answer, Please include a sample file in the initial post.

VB Code to copy data from one sheet to another sheet

Ateeb Ali

Member
Dear Sir
File Enclosed, it has two sheets "DC" and "DC Records"
Getting some error on "save records" button, it is not copying UOM and quantities, also pasting my code below;
Code:
Sub Save_Data()
Dim rng As Range
  Dim i As Long
  Dim a As Long
  Dim rng_dest As Range
  Application.ScreenUpdating = False
  i = 1
  Set rng_dest = Sheets("DC Record").Range("E:G")
  ' Find first empty row in columns E:G on sheet DC Record
  Do Until WorksheetFunction.CountA(rng_dest.Rows(i)) = 0
    i = i + 1
  Loop
  'Copy range C13:I23 on sheet DC to Variant array
  Set rng = Sheets("DC").Range("C13:I23")
    ' Copy rows containing values to sheet DC Record
  For a = 1 To rng.Rows.Count
    If WorksheetFunction.CountA(rng.Rows(a)) <> 0 Then
      rng_dest.Rows(i).Value = rng.Rows(a).Value
      'Copy DC number
      Sheets("DC Record").Range("A" & i).Value = Sheets("DC").Range("I5").Value
      'Copy Date
      Sheets("DC Record").Range("B" & i).Value = Sheets("DC").Range("C5").Value
      'Copy Customer
      Sheets("DC Record").Range("C" & i).Value = Sheets("DC").Range("D7").Value
      'Copy P.O number
      Sheets("DC Record").Range("D" & i).Value = Sheets("DC").Range("H7").Value
      
    i = i + 1
    End If
  Next a
  Application.ScreenUpdating = True

End Sub
 

Attachments

  • DC TO Invoice.xlsb
    27.2 KB · Views: 16
Hi !​
That's normal as you forgot in your code these columns, just amend it accordingly …
 
Dear Sir
Sorry dont understand, I have mentioned it in my code like UOM and quantities to be copied from "Sheet DC RANGE(H13:I23)" and to be paste in "Sheet DC Record RANGE (F:G)"
Can you please amend in my code
 
Last edited by a moderator:
In which codeline did you « mentioned it » ?!
As I yet wrote you just forgot it …
Tips fo beginners :​
  • Do not ever merge cells for a smart worksheet, that's easier to manage under VBA.

  • A smart worksheet does not have empty rows within a data range but use Excel tables …
 
In which codeline did you « mentioned it » ?! As I yet wrote you just forgot it …​
Dear Sir
if possible, please open my file, see below in my code;
Set rng_dest = Sheets("DC Record").Range("E:G")
' Find first empty row in columns E:G on sheet DC Record
Do Until WorksheetFunction.CountA(rng_dest.Rows(i)) = 0
i = i + 1
Loop
'Copy range C13:I23 on sheet DC to Variant array
Set rng = Sheets("DC").Range("C13:I23")
' Copy rows containing values to sheet DC Record
For a = 1 To rng.Rows.Count
If WorksheetFunction.CountA(rng.Rows(a)) <> 0 Then
rng_dest.Rows(i).Value = rng.Rows(a).Value
 
See tips in my previous post, try the same on a new test worksheet but without any merged cells, that's the issue !​
As in your mind you copy 3 columns but in fact C:I means 7 columns so 'cause of merged cells you can't copy entire row​
but only needed columns like C alone (as merged) and H:I so two codelines are necessary …​
 
As a beginner reminder : the easy way to go is without any merged cells ! (only 2 necessary codelines to copy all data …)
A For … Next loop is useless as you can directly copy all the data range at once …​
According to your attachment an example for data in cell C : rng_dest.Rows(i).columns("E").Value2 = rng.Rows(a).Columns("C").Value2 …​
 
Ateeb Ali
You asked 'complete code'
... if someone just would write it, then You will ask same with next Your thread.
You would try to learn...
Check Your code line-by-line and same time follow what do it do?
Do Your code do as You would like it work?
Is there needed steps?
 
Noted dear thanks, its done

Revise code after unmerge cell
Code:
Sub Save_Data()
Dim rng As Range
  Dim i As Long
  Dim a As Long
  Dim rng_dest As Range
  Application.ScreenUpdating = False
  i = 1
  Set rng_dest = Sheets("DC Record").Range("E:G")
  ' Find first empty row in columns E:G on sheet DC Record
  Do Until WorksheetFunction.CountA(rng_dest.Rows(i)) = 0
    i = i + 1
  Loop
  'Copy range C13:E23 on sheet DC to Variant array
  Set rng = Sheets("DC").Range("C13:E23")
    ' Copy rows containing values to sheet DC Record
  For a = 1 To rng.Rows.Count
    If WorksheetFunction.CountA(rng.Rows(a)) <> 0 Then
      rng_dest.Rows(i).Value = rng.Rows(a).Value
      'Copy DC number
      Sheets("DC Record").Range("A" & i).Value = Sheets("DC").Range("E5").Value
      'Copy Date
      Sheets("DC Record").Range("B" & i).Value = Sheets("DC").Range("C5").Value
      'Copy Customer
      Sheets("DC Record").Range("C" & i).Value = Sheets("DC").Range("C7").Value
      'Copy P.O number
      Sheets("DC Record").Range("D" & i).Value = Sheets("DC").Range("E7").Value
      
    i = i + 1
    End If
  Next a
  Application.ScreenUpdating = True

End Sub
 
Ateeb Ali
Sorry that I wrote many lines.
Seems that You maybe read those, but that other part seems still missed.
Did You also checked that Your code could do those steps which You would like it to do? ... ... ... no.
Have You tried to do this with paper and pencil ... or manually?
Ps For me, unmerge or merged cells - no matter, if won't use those ranges as those are.
 
I am really a beginner, i would appreciate if you can give me complete code as it is easy for you
As you wrote « your code » I let you to amend the source & destination columns, a child level difficulty … :rolleyes:
According to your last attachment 'your' Save_Data procedure revamped :​
Code:
    Dim L&, R&
    L = [B12].CurrentRegion.Columns(2).Find("*", , xlValues, , , xlPrevious).Row - 12:  If L < 1 Then Beep: Exit Sub
    R = Sheet4.Cells(Rows.Count, 1).End(xlUp)(2).Row
    Sheet4.Cells(R, 1).Resize(L, 4).Value2 = Array([E5], [C5], [C7], [E7])
    Sheet4.Cells(R, 5).Resize(L, 3).Value2 = [C13:E13].Resize(L).Value2
Do you like it ? So thanks to click on bottom right Like !​
 
Really appreciate very good code, can you add this that if DC#, PO#, Date, and Item description are same then not to copy data as it create duplication, is it possible through VB?
 
So you dont't Like the code … As respecting results in your attachments, it reproduces the same than your procedure ‼​
It's not a good idea on Excel side to leave some columns blank / empty.​
Anyway if I well copy, just amend the codeline by deleting L in the Resize statement …​
 
So you do not ever Like the code, read post #14 under the code …​
On Excel side it's not a duplication - could be a mess without - and if I well catched I gave you in my previous post how to …​
 
Anyway if I well copy, just amend the codeline by deleting L in the Resize statement …
Sir
When removing L, it is just copying the first line of table and not the others
Following code is perfect
Code:
 Dim L&, R&
    L = [B12].CurrentRegion.Columns(2).Find("*", , xlValues, , , xlPrevious).Row - 12:  If L < 1 Then Beep: Exit Sub
    R = Sheet4.Cells(Rows.Count, 1).End(xlUp)(2).Row
    Sheet4.Cells(R, 1).Resize(L, 4).Value2 = Array([E5], [C5], [C7], [E7])
    Sheet4.Cells(R, 5).Resize(L, 3).Value2 = [C13:E13].Resize(L).Value2
Is it just possible that when these fields are identical and already available in DC record, its gives an alert of duplicate entry and restrict user for duplicate entry? (E5, C5, C7, E7, C13:E23) If this record already available in sheet "DC Record"
 
As it's easier with an expecting result workbook or just with a targeted accurate explanation …​
Next event code raises when a cell changes in C13:E23 if any empty cell within the row,​
you must paste it to the Sheet3 (DC) worksheet module : (Edit v3)​
Code:
Private Sub Worksheet_Change(ByVal Target As Range)
      Const C = 4, D = "¤"
        Dim T$, Rg As Range, A$, S$, V
        If Target.CountLarge > 1 Then Exit Sub
    If Not Intersect([C13:E23], Target) Is Nothing Then
            T = Replace("C¤:E¤", D, Target.Row):  If Application.CountBlank(Range(T)) Then Exit Sub
        With Sheet4.[A1].CurrentRegion.Rows
               Set Rg = .Columns(C).Find([E7].Value2, , xlValues, xlWhole)
            If Not Rg Is Nothing Then
               A = Rg.Address
               S = Join(Array([E5], [C5], [C7], [E7]), D) & D & Join(Application.Index(Range(T).Value2, 1, [{1,2,3}]), D)
               V = [COLUMN(A:G)]
             Do
                If S = Join(Application.Index(.Item(Rg.Row).Value, 1, V), D) Then
                    Range("C5,E5,C7,E7," & T).Select
                    Target.Activate
                    MsgBox "This row already exists in " & .Parent.Name & " #" & Rg.Row, vbExclamation, " Invalid row entry"
                    Target.Select
                    Application.EnableEvents = False
                    Target.ClearContents
                    Application.EnableEvents = True
                    Exit Do
                End If
                    Set Rg = .Columns(C).FindNext(Rg)
             Loop Until Rg.Address = A
                    Set Rg = Nothing
            End If
        End With
    End If
End Sub
You may Like it !​
 
Sorry I am writing again, your solution worked perfect when we are typing same detail in sheet 3
I have attached updated sheet, what I want that when we press button save record and if record already exist in Sheet4 (DC Record), its gives that error that record already save.
 

Attachments

  • DC TO Invoice.xlsb
    52.2 KB · Views: 10
Code:
Private Sub Save_Data()
  Const D = "&""¤""&", F = "TRANSPOSE(E5,C5,C7,E7,C§:C#,D§:D#,E§:E#)", H = 12
    Dim L%, V, Z%
        L = [C24].End(xlUp).Row:  If L <= H Then Beep: Exit Sub
  With Sheet4.Cells(Rows.Count, 1).End(xlUp)
    If .Row > 1 Then
        V = Application.Match(Evaluate(Replace(Replace(Replace(F, "#", L), "§", H + 1), ",", D)), _
           .Parent.Evaluate(Replace(Replace("A2:A#,B2:B#,C2:C#,D2:D#,E2:E#,F2:F#,G2:G#", "#", .Row), ",", D)), 0)
        For Z = 1 To L - H:  V(Z) = IIf(IsError(V(Z)), False, H + Z):  Next
        V = Join(Filter(V, False, False), ", ")
        If V > "" Then MsgBox "Data already saved in" & vbLf & vbLf & "row #" & V, vbExclamation, " Operation Aborted": Exit Sub
    End If
       .Offset(1).Resize(L - H, 4).Value2 = Array([E5], [C5], [C7], [E7])
       .Offset(1, 4).Resize(L - H, 3).Value2 = Cells(H + 1, 3).Resize(L - H, 3).Value2
  End With
End Sub
You should Like it !
 
Back
Top