Help needed to modify the following code so that the data is copied only once.

raghuprabhu · Aug 24th 2017

Hi All,
I have attached four workbooks. 3 from suppliers and one masterdata.
The three supplier’ workbooks are Supplier-a.xlsx, Supplier-b.xlsx, Supplier-c.xlsx and the master zMaster.xlsm
I am able to transfer the data from the suppliers’ workbooks to the master workbook, but, I have to hard code the number of lines.
I want to alter the code below to do two things
1. Be able to drag thousands of lines.
2. Update the lines that have been dragged to show “Yes” in column E and they are not dragged again.
Regards
Raghu

Code

Sub LoopThroughDirectory()
Dim MyFile As String
Dim eRow As Long
Dim LastRow As Long
Dim i As Long








Dim FilePath As String
FilePath = ActiveWorkbook.Path & "\"
Debug.Print FilePath




MyFile = Dir(FilePath)
Debug.Print MyFile




    Do While Len(MyFile) > 0
        If MyFile = "zmaster.xlsm" Then
            Exit Sub
        End If
        
        Workbooks.Open (FilePath & MyFile)




                Range("A2:D20").Copy




        ActiveWorkbook.Close
    
        eRow = Sheet1.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
        ActiveSheet.Paste Destination:=Worksheets("Sheet1").Range(Cells(eRow, 1), Cells(eRow, 5))
        
        MyFile = Dir
        ActiveWorkbook.Save
    Loop
End Sub
[COLOR=#444444][FONT=Lato][/FONT][/COLOR]

Display More

**Carim** · Aug 24th 2017

Re: Help needed to modify the following code so that the data is copied only once.

Hello,

You request looks like ... a job assignment ... :wink:

May be you should post this mission ... in the HIRE section ...

jaslake · Aug 25th 2017

Re: Help needed to modify the following code so that the data is copied only once.

Hi raghuprabhu

Welcome to the Forum!!

Replace your LoopThroughDirectory Code with this...

Code

Sub LoopThroughDirectory()
    Dim MyFile As String
    Dim eRow As Long
    Dim tgtWb As Workbook
    Dim tgtWs As Worksheet
    Dim srcWb As Workbook
    Dim srcWs As Worksheet
    Dim LR As Long
    Dim FilePath As String
    FilePath = ThisWorkbook.Path & "\"
    '    Debug.Print FilePath
    Set tgtWb = ThisWorkbook
    Set tgtWs = tgtWb.Sheets("Sheet1")
    MyFile = Dir(FilePath)
    '    Debug.Print MyFile
    Application.ScreenUpdating = False
    Do While Len(MyFile) > 0
        If MyFile = "zMaster.xlsm" Then
            Exit Sub
        End If
        Set srcWb = Workbooks.Open(FilePath & MyFile)
        Set srcWs = srcWb.Sheets("Sheet1")
        With srcWs
            LR = .Cells.Find("*", .Cells(.Rows.Count, .Columns.Count), SearchOrder:=xlByRows, _
                             SearchDirection:=xlPrevious).Row
            If Not .AutoFilterMode Then
                .Rows("1:1").AutoFilter
            End If
            .Range("A1:E" & LR).AutoFilter Field:=5, Criteria1:="="
            If Not .AutoFilter.Range.Columns(1).SpecialCells(xlCellTypeVisible).Count - 1 = 0 Then
                .Range("A2:D" & LR).SpecialCells(xlCellTypeVisible).Copy
                eRow = tgtWs.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
                tgtWs.Cells(eRow, "A").PasteSpecial
                .Range(.Cells(2, 5), .Cells(LR, 5)).SpecialCells(xlCellTypeVisible).Value = "Yes"
            Else
                .AutoFilterMode = False
            End If
            Application.DisplayAlerts = False
            srcWb.Close True
            Application.DisplayAlerts = True
            MyFile = Dir
        End With
    Loop
    tgtWb.Save
    Application.ScreenUpdating = True
End Sub

Display More

Help needed to modify the following code so that the data is copied only once.

Participate now!

Share