Auto copy data from workbook to other workbook

[Mohammednt0]

Good Day,
I need Code, to auto copy data from workbook to other workbook,

Step.1: from workbook.1 the code need to copy the next NO. [in column B] not the next Cell!! Because some cells have same numbers.

Step.2: Go to workbook2 past the NO. in data filter (see the pic) [which is in column B also] to filter out the required records.

Step.3: copy all records from C1 to AM1, with below records if exists,

Example1: let’s see the filter brought 3 records, then it will copy from C1:AM1 To C3:AM3 , I will need the code to copy all of the 8 records,

Example1: let’s see the filter brought 8 records, then it will copy from C1:AM1 To C8:AM8 , I will need the code to copy all of the 8 records,

Also, if there are any hidden columns the code will ignore them [will not copy the hidden columns in between].

Step.4: Go to workbook.1 , Go to the number that we copied it before, and Past the records from C to P

Step.5: Go to the next NO. in workbook.1 and repeat all the steps again till the end of all the Numbers in column B

thanks in advance

[Mohammednt0]

if my explaining is not clear i will upload a small video to show you the steps manually , thanks

[HansV]

Will column B in workbook 1 be sorted in ascending (or descending) order?

[Mohammednt0]

Will column B in workbook 1 be sorted in ascending (or descending) order?

it must me ascending

[Mohammednt0]

Will column B in workbook 1 be sorted in ascending (or descending) order?

it must me ascending

all the numbers must be ascending first to start all the work

[HansV]

It's not entirely clear to me what you want, but see if this works for you:

Code: Select all

Sub CopyData()
    Dim wsh1 As Worksheet
    Dim wsh2 As Worksheet
    Dim r As Long
    Dim m As Long
    Dim n As Long
    Dim s As String
    Application.ScreenUpdating = False
    Set wsh1 = Workbooks("Book1.xlsm").Worksheets("Sheet1")
    wsh1.Range("B1").CurrentRegion.Sort Key1:=wsh1.Range("B1"), Header:=xlYes
    m = wsh1.Range("B" & wsh1.Rows.Count).End(xlUp).Row
    Set wsh2 = Workbooks("Book2.xlsm").Worksheets("Sheet2")
    If wsh2.FilterMode Then
        wsh2.ShowAllData
    End If
    n = wsh2.Range("B" & wsh2.Rows.Count).End(xlUp).Row
    s = wsh1.Range("B1").Value
    For r = 2 To m
        If wsh1.Range("B" & r).Value <> s Then
            s = wsh1.Range("B" & r).Value
            wsh2.Range("B:B").AutoFilter Field:=1, Criteria1:="=" & s
            If wsh2.Range("B1:B" & m).SpecialCells(xlCellTypeVisible).Rows.Count > 1 Then
                wsh2.Range("C2:AM" & n).Copy wsh1.Range("C" & r)
            End If
        End If
    Next r
    wsh2.ShowAllData
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub

[Mohammednt0]

error in this line:

Set wsh1 = Workbooks("Book1.xlsm").Worksheets("Sheet1")


i think it mans i should correct the file name and sheet names , i tried but nothing happen !!

[Mohammednt0]

It's not entirely clear to me what you want, but see if this works for you:

Code: Select all

Sub CopyData()
    Dim wsh1 As Worksheet
    Dim wsh2 As Worksheet
    Dim r As Long
    Dim m As Long
    Dim n As Long
    Dim s As String
    Application.ScreenUpdating = False
    Set wsh1 = Workbooks("Book1.xlsm").Worksheets("Sheet1")
    wsh1.Range("B1").CurrentRegion.Sort Key1:=wsh1.Range("B1"), Header:=xlYes
    m = wsh1.Range("B" & wsh1.Rows.Count).End(xlUp).Row
    Set wsh2 = Workbooks("Book2.xlsm").Worksheets("Sheet2")
    If wsh2.FilterMode Then
        wsh2.ShowAllData
    End If
    n = wsh2.Range("B" & wsh2.Rows.Count).End(xlUp).Row
    s = wsh1.Range("B1").Value
    For r = 2 To m
        If wsh1.Range("B" & r).Value <> s Then
            s = wsh1.Range("B" & r).Value
            wsh2.Range("B:B").AutoFilter Field:=1, Criteria1:="=" & s
            If wsh2.Range("B1:B" & m).SpecialCells(xlCellTypeVisible).Rows.Count > 1 Then
                wsh2.Range("C2:AM" & n).Copy wsh1.Range("C" & r)
            End If
        End If
    Next r
    wsh2.ShowAllData
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub

MR Hans V , i have a better idea!! , im sorry for giving you hard time in writing the first code, anyway using the new concept it will be easy

simply what i need is a code that will scan column B and compare it against column B in another Excel file

1- if the code find new data in column B , the whole record will be copied
2- if the code did not find any new data in column B , message will pop-up says "data is up to date"

Columns must be ascending order

thanks i will be waiting for your reply

[HansV]

But what should happen if a value occurs more than once in column B in the first worksheet?

[Mohammednt0]

But what should happen if a value occurs more than once in column B in the first worksheet?

ummm, i didn't notice that, correct the name may be duplicated in my files , [occurs more than once in both files]

is it possible to copy all of duplicated records!!, i mean if the code found duplicated names it will copy all the records for all duplicated names


hope this is clear to you , sorry for the Hassle

[HansV]

I'm not sure how that would work. Could you post a small sample workbook with three sheets:

- The first sheet before the macro has run
- The second sheet
- The first sheet as it should look after the macro has run

You don't have to include lots of rows, but enough to give a clear idea of the situation.

[Mohammednt0]

i will do that plus i will create a small video explaining to you everything, and thanks for your time in advance

[Mohammednt0]

I'm not sure how that would work. Could you post a small sample workbook with three sheets:

- The first sheet before the macro has run
- The second sheet
- The first sheet as it should look after the macro has run

You don't have to include lots of rows, but enough to give a clear idea of the situation.

i created the workbook, if the workbook sample did not clarify the idea i will create the video

important: Sheet.1 will represent excel file no.1, and sheet2. will represent excel file no.2

in reality there are no sheets only 2 excel files, so when you are coding do not include orders that are representing sheets

, thank you so much for your help,

[HansV]

In your sample workbook, the number of rows for each SHOP DWG on Sheet1 is exactly the same as the number of rows for that SHOP DWG on Sheet2. Will this ALWAYS be true?

[Mohammednt0]

In your sample workbook, the number of rows for each SHOP DWG on Sheet1 is exactly the same as the number of rows for that SHOP DWG on Sheet2. Will this ALWAYS be true?

sorry mr.hans i will edit it there is a small problem

[Mohammednt0]

as i said before i just want the new data to be copied to the first workbook, and if the code did not find any new data message will pop-up says "Data is up to date"

see the attached file for better understanding

[Mohammednt0]

if something is not clear please let me now

[HansV]

The code can probably be optimized, but here is a macro that works in your sample workbook:

Code: Select all

Sub CopyData()
    Dim wsh1 As Worksheet
    Dim wsh2 As Worksheet
    Dim s As Long
    Dim c As Long
    Dim t As Long
    Dim d As Long
    Dim m As Long
    Dim rng As Range
    Dim v As String

    Application.ScreenUpdating = False

    ' Modify the name of the workbook and the worksheet
    ' The code assumes that both workbooks are already open in Excel.
    Set wsh1 = Workbooks("Workbook.xls").Worksheets("Sheet.1")
    Set wsh2 = Workbooks("Workbook.xls").Worksheets("Sheet.2 (Data)")
    
    Set rng = wsh1.Range("B:B")
    t = wsh1.Range("B" & wsh1.Rows.Count).End(xlUp).Row
    m = wsh2.Range("B" & wsh2.Rows.Count).End(xlUp).Row

    For s = 2 To m
        v = wsh2.Range("B" & s).Value
        If rng.Find(What:=v, LookAt:=xlWhole) Is Nothing Then
            Do
                t = t + 1
                d = 0
                For c = 1 To 39 ' AM is column 39
                    If wsh2.Cells(s, c).EntireColumn.Hidden = False Then
                        d = d + 1
                        wsh2.Cells(s, c).Copy Destination:=wsh1.Cells(t, d)
                    End If
                Next c
                s = s + 1
            Loop Until wsh2.Range("B" & s).Value <> v
        End If
    Next s

    Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub

[Mohammednt0]

The code can probably be optimized, but here is a macro that works in your sample workbook:

Code: Select all

Sub CopyData()
    Dim wsh1 As Worksheet
    Dim wsh2 As Worksheet
    Dim s As Long
    Dim c As Long
    Dim t As Long
    Dim d As Long
    Dim m As Long
    Dim rng As Range
    Dim v As String

    Application.ScreenUpdating = False

    ' Modify the name of the workbook and the worksheet
    ' The code assumes that both workbooks are already open in Excel.
    Set wsh1 = Workbooks("Workbook.xls").Worksheets("Sheet.1")
    Set wsh2 = Workbooks("Workbook.xls").Worksheets("Sheet.2 (Data)")
    
    Set rng = wsh1.Range("B:B")
    t = wsh1.Range("B" & wsh1.Rows.Count).End(xlUp).Row
    m = wsh2.Range("B" & wsh2.Rows.Count).End(xlUp).Row

    For s = 2 To m
        v = wsh2.Range("B" & s).Value
        If rng.Find(What:=v, LookAt:=xlWhole) Is Nothing Then
            Do
                t = t + 1
                d = 0
                For c = 1 To 39 ' AM is column 39
                    If wsh2.Cells(s, c).EntireColumn.Hidden = False Then
                        d = d + 1
                        wsh2.Cells(s, c).Copy Destination:=wsh1.Cells(t, d)
                    End If
                Next c
                s = s + 1
            Loop Until wsh2.Range("B" & s).Value <> v
        End If
    Next s

    Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub

MR Hans thank you so so so so so much , the code worked perfectly,!!!

also im sorry i was not able to express what i want in correct way , i was trying to not giving you hard time

But i have 2 problems ,

Problem 1 : this code took almost 1 min to finish only 21 records !!, i have thousands and thousands of records [37900 records],
How optimize it!! is there a way to make it very fast !!


Problem 2 :

- i need a message when data is successfully imported
- i need a message when data importing is failed or some error happened!
- i need a message when data is up to date

[HansV]

The following version displays message boxes, and it should be faster:

Code: Select all

Sub CopyData()
    Dim wsh1 As Worksheet
    Dim wsh2 As Worksheet
    Dim s As Long
    Dim c As Long
    Dim n As Long
    Dim t As Long
    Dim d As Long
    Dim m As Long
    Dim rng As Range
    Dim v As String
    Dim arr1
    Dim arr2
    Dim vis(1 To 39) As Boolean

    Application.ScreenUpdating = False

    ' Modify the name of the workbook and the worksheet
    ' The code assumes that both workbooks are already open in Excel.
    Set wsh1 = Workbooks("Workbook.xlsm").Worksheets("Sheet.1")
    Set wsh2 = Workbooks("Workbook.xlsm").Worksheets("Sheet.2 (Data)")
    
    Set rng = wsh1.Range("B:B")

    For c = 1 To 39
        vis(c) = Not wsh2.Cells(1, c).EntireColumn.Hidden
    Next c

    arr2 = wsh2.UsedRange.Value
    m = UBound(arr2, 1)
    ReDim arr1(1 To m, 1 To 16)

    For s = 2 To m
        v = arr2(s, 2)
        If rng.Find(What:=v, LookAt:=xlWhole) Is Nothing Then
            t = t + 1
            d = 0
            For c = 1 To 39 ' AM is column 39
                If vis(c) Then
                    d = d + 1
                    arr1(t, d) = arr2(s, c)
                End If
            Next c
        End If
    Next s

    If t = 0 Then
        MsgBox "No new data!", vbInformation
    Else
        n = wsh1.Range("B" & wsh1.Rows.Count).End(xlUp).Row + 1
        wsh1.Range("A" & n).Resize(m, 16).Value = arr1
        MsgBox "Finished importing new data!", vbInformation
    End If

ExitHandler:
    Application.ScreenUpdating = True
    Exit Sub

ErrHandler:
    MsgBox "Something went wrong!", vbCritical
    Resume ExitHandler
End Sub