how to transfer data from one workbook to another workbook

[amo]

good afternoon

how to transfer data from one workbook to another workbook based on header names

thank you

 

[Anthony47]

I understand you have two tables which have the columns in different sequence

In this case you might use Application.Match to determine the index of a header in the target table, then use it to determine the target destination area

If your data are organized in canonical Tables then it might be simpler, because you can use the header directly to identify the destination position, example:

    ThisWorkbook.Sheets("MASTRO").Range("Table1[[#All],[Description]]").Copy _
       Destination:=Workbooks("MyOldCopy.xlsm").Sheets("MASTRO-OLD").Range("Table1[[#Headers],[Description]]")

Bye

 

[mohadin]

Hi
As I understand
Give this a try

Sub test()
    Dim rng As Range
    Dim a As Variant
    Dim i, ii, c, r, x
    Application.ScreenUpdating = False
    a = Sheets("sheet1").UsedRange
    With CreateObject("scripting.dictionary")
        For i = 1 To UBound(a, 2)
            If Not .exists(a(1, i)) Then
                x = ""
                For ii = 2 To UBound(a)
                    x = x & a(ii, i) & Chr(2)
                Next
                .Add a(1, i), x
            End If
        Next
        Sheets("sheet2").Select
        For Each rng In Range("g1:j1")    '<<< to be changed as yours
            c = rng.Column: r = rng.Row
            x = .Item(rng.Value)
            x = Split(x, Chr(2))
            Cells(r, c).Offset(1, 0).Resize(UBound(x)) = x
        Next
    End With
    Application.ScreenUpdating = True
End Sub

 

[amo]

@mohadin
@Anthony47


Thank you for the response
Sorry
Can you give me an example that I can download

 

[mohadin]

Dropbox - File Deleted - Simplify your life

www.dropbox.com

 

[amo]

@mohadin

Thank you so much for your help

which are expected

Transfer to another workbook by first selecting the file ?

 

[Anthony47]

Now I don't understand if your problem is selecting a file or selecting a column or what.
I think you should spend some of your time to tell us about your environment, your needs, and for which part of the job you are asking for some help

In the meantime I wasted my time to prepare the following demo workbook:

4AMO-Mr_Demo_C01011.xlsm

Shared with Dropbox

www.dropbox.com

It contains two tables in two different sheets and the Sub AmoDemo that is intended to demonstrate how using Application.Match to get the index of the Source and the Destination column based on the column header

Sub AmoDemo()
Dim SoTab As Range, DeTab As Range, Msg As String
Dim ColToCopy, mySInd, myDInd, I As Long
'
Set SoTab = Workbooks("4AMO-Mr_Demo_C01011.xlsm").Sheets("Foglio1").Range("A2") '<<< Source Table Starting address
Set DeTab = Workbooks("4AMO-Mr_Demo_C01011.xlsm").Sheets("Foglio2").Range("B2") '<<< Destination Table Starting address
ColToCopy = Array("B", "D", "E")                                                    '<<< List of Headers to copy
'
For I = 0 To UBound(ColToCopy)
    mySInd = Application.Match(ColToCopy(I), SoTab.Resize(1, 100), False)       'Get Source Column Index
    myDInd = Application.Match(ColToCopy(I), DeTab.Resize(1, 100), False)       'Get Destination Col Index
    If Not (IsError(mySInd) Or IsError(myDInd)) Then                            'if both valid, then...
        Range(SoTab.Cells(2, mySInd), SoTab.Cells(1, mySInd).End(xlDown)).Copy _
          Destination:=DeTab.Cells(1, myDInd).End(xlDown).Offset(1, 0)          '.... copy from.. to..
    Else
        Msg = Msg & ", " & ColToCopy(I)                                         '...else log the missed header
    End If
Next I
'Completion message:
If Len(Msg) > 0 Then
    MsgBox ("Completed, EXCEPT:" & vbCrLf & Mid(Msg, 3))
Else
    MsgBox ("Completed...")
End If
End Sub

Copy the code in a standard module of your vba project; the lines marked <<< need to be customized on your situation. To be more specific, SoTab and DeTab need to point to the topleft cell of your table headers; you will specify the workbook, the sheet and the cell address.
ColToCopy is the list of your headers of your columns to copy.

A final msgbox will list any column that was not found either in the source table or the destination one.

Bye

 

[mohadin]

Hi,
Try this one hope It's Ok with you

Sub OMA2()
    Dim fDialog As FileDialog
    Dim wbk, Mywbk As Workbook
    Dim rng As Range
    Dim a As Variant
    Dim i, ii, c, r, x, y, z
    Set Mywbk = ActiveWorkbook
    Application.ScreenUpdating = False
    On Error Resume Next
    Set fDialog = Application.FileDialog(msoFileDialogFilePicker)
    With fDialog
        .AllowMultiSelect = False
        .Title = "PICK FILE"
        .InitialFileName = "C:\"
        .Filters.Clear
        .Filters.Add "All supported files", "*.xlsm", "*.xlsx"
        .SelectedItems.Application.Sort
        If .Show = True Then
            Dim fPath As Variant
            fPath = .SelectedItems.Item(1)
            Set wbk = Workbooks.Open(Filename:=fPath)
        End If
    End With
    Mywbk.Activate
    a = Mywbk.Sheets("sheet1").UsedRange
    With CreateObject("scripting.dictionary")
        For i = 1 To UBound(a, 2)
            If Not .exists(a(1, i)) Then
                x = ""
                For ii = 2 To UBound(a)
                    x = x & a(ii, i) & Chr(2)
                Next
                .Add a(1, i), x
            End If
        Next
        For Each rng In wbk.Sheets("sheet2").Range("G1:J1")    '<<< to be changed as yours
            c = rng.Column: r = rng.Row
            y = rng.Value
            x = .Item(y)
            x = Split(x, Chr(2))
            wbk.Sheets("sheet2").Cells(r, c).Offset(1, 0).Resize(UBound(x)) = x
        Next
        End With
    Sheets("sheet2").Select
    Application.ScreenUpdating = True
End Sub

 

[amo]

thank you @mohadin
as I expected

But for the copied ones, why only the first line
why not all

photo attached

 

[mohadin]

OOOps
Sorry for this
Just Replace this line

 wbk.Sheets("sheet2").Cells(r, c).Offset(1, 0).Resize(UBound(x)) = x

With

wbk.Sheets("sheet2").Cells(r, c).Offset(1, 0).Resize(UBound(x)) = Application.Transpose(x)