Search multiple headings(Columns) in other sheet, copy data and paste in main file

[Zahid0111]

I need a VBA code for a button which when clicked browse for other excel file, search for specific sheet named “Farmer History” in it. In this sheet it looks for A1 complete row and search heading “Crop Area” and copy this column data to main file(where button embedded) in sheet named “Berkhund” at F Column below last cell is used.

The same to be done for other 2 columns too i.e

Looks for “Target Qty” in first row at same sheet “Farmer History” and paste in main file sheet “Berkhund” at R Column below last cell is used

Looks for “Commulative Sold” in first row at same sheet “Farmer History” and paste in main file sheet “Berkhund” at S Column below last cell is used.Code which i tried is given below but it cannot BROWSE for file, search and paste back in main file:

 

[mumps]

Will the file you want to find always be the same file? If so, what is the full path to the folder containing the file?

 

[Zahid0111]

Will the file you want to find always be the same file? If so, what is the full path to the folder containing the file?

Yes it will look for same file...
File can be anywhere, user will select the file by using Application.GetOpenFilename method..

 

[mumps]

Try:

Sub CopySheet()
    Application.ScreenUpdating = False
    Dim flder As FileDialog, FileName As String, FileChosen As Integer, wkbSource As Workbook, desWS As Worksheet, header As Range, LastRow As Long
    Set desWS = ThisWorkbook.Sheets("Berkhund")
    Set flder = Application.FileDialog(msoFileDialogFilePicker)
    flder.Filters.Add "Excel Macros Files", "*.xlsx"
    FileChosen = flder.Show
    FileName = flder.SelectedItems(1)
    Set wkbSource = Workbooks.Open(FileName)
    With wkbSource.Sheets("Farmer History")
        LastRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
        Set header = .Rows(1).Find("Crop Area", LookIn = xlValues, lookat:=xlWhole)
        If Not header Is Nothing Then
            Cells(2, header.Column).Resize(LastRow - 1).Copy desWS.Cells(desWS.Rows.Count, "F").End(xlUp).Offset(1)
        End If
        Set header = .Rows(1).Find("Target Qty", LookIn = xlValues, lookat:=xlWhole)
        If Not header Is Nothing Then
            Cells(2, header.Column).Resize(LastRow - 1).Copy desWS.Cells(desWS.Rows.Count, "R").End(xlUp).Offset(1)
        End If
        Set header = .Rows(1).Find("Commulative Sold", LookIn = xlValues, lookat:=xlWhole)
        If Not header Is Nothing Then
            Cells(2, header.Column).Resize(LastRow - 1).Copy desWS.Cells(desWS.Rows.Count, "S").End(xlUp).Offset(1)
        End If
    End With
    wkbSource.Close savechanges:=False
    Application.ScreenUpdating = True
End Sub

 

[Zahid0111]

Hi thank you for reply...but i m getting the attached error, can you please check this

 

[mumps]

In the second picture you posted it looks like the following 2 lines of code have a space to the left of the sheet name.

Set header = .Rows(1).Find(" Crop Area", LookIn = xlValues, lookat:=xlWhole)
Set header = .Rows(1).Find(" Target City", LookIn = xlValues, lookat:=xlWhole)

The macro that I posted does not have those spaces. Check the macro and make sure that those spaces are removed.

 

[Zahid0111]

Yes the spaces are also in source sheet as attached in picture that,s why i copied the header from source sheet to the code

 

[mumps]

My apologies. I somehow missed putting in a colon after "Lookin". Try the following:

Sub CopySheet()
    Application.ScreenUpdating = False
    Dim flder As FileDialog, FileName As String, FileChosen As Integer, wkbSource As Workbook, desWS As Worksheet, header As Range, LastRow As Long
    Set desWS = ThisWorkbook.Sheets("Berkhund")
    Set flder = Application.FileDialog(msoFileDialogFilePicker)
    flder.Filters.Add "Excel Macros Files", "*.xlsx"
    FileChosen = flder.Show
    FileName = flder.SelectedItems(1)
    Set wkbSource = Workbooks.Open(FileName)
    With wkbSource.Sheets("Farmer History")
        LastRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
        Set header = .Rows(1).Find("Crop Area", LookIn:=xlValues, lookat:=xlWhole)
        If Not header Is Nothing Then
            Cells(2, header.Column).Resize(LastRow - 1).Copy desWS.Cells(desWS.Rows.Count, "F").End(xlUp).Offset(1)
        End If
        Set header = .Rows(1).Find("Target Qty", LookIn:=xlValues, lookat:=xlWhole)
        If Not header Is Nothing Then
            Cells(2, header.Column).Resize(LastRow - 1).Copy desWS.Cells(desWS.Rows.Count, "R").End(xlUp).Offset(1)
        End If
        Set header = .Rows(1).Find("Commulative Sold", LookIn:=xlValues, lookat:=xlWhole)
        If Not header Is Nothing Then
            Cells(2, header.Column).Resize(LastRow - 1).Copy desWS.Cells(desWS.Rows.Count, "S").End(xlUp).Offset(1)
        End If
    End With
    wkbSource.Close savechanges:=False
    Application.ScreenUpdating = True
End Sub

 

[Zahid0111]

Great, now it,s working very fine....Thank you so much for your time and work...

 

[mumps]

You are very welcome.