Need a Find/Match Macro Desperately

[copleyr]

Hello all:

I am in desperate need of efficiency with constantly updating files (1000's each week)

1) I need a macro that can look in column "A" of my "Index" worksheet.

2) I then need it to match the first 7 characters of each entry in column "A" with the file names in the folder "C:\Users\copleyr\Desktop\All/". All of the files in this folder are excel files, each with the same naming convention.

3) once it matches, I need it to copy the row of the matching 7 characters in the "Index" worksheet, columns "A" through "BM", and paste it in the "Defaults" tab, row "70" of the matching file in "C:\Users\copleyr\Desktop\All/" .


I have some pieces of macro that helps (below), from prior macros. I just need somebody to help me consolidate everything:

SummarySheet = ActiveWorkbook.Name
MyPathName = "C:\Users\copleyr\Desktop\All/" MyFileName = Dir(MyPathName)
X = 0
Do While MyFileName <> ""
    X = X + 1
    Workbooks.Open (MyPathName & MyFileName)
    Application.DisplayAlerts = False
    Sheets("Defaults").Range("A70:BM70").Copy
    Workbooks(SummarySheet).Activate
    Range("A" & X & ":BM" & X).PasteSpecial xlPasteValuesAndNumberFormats
    Range("A" & X & ":BM" & X).PasteSpecial xlPasteFormats
    Workbooks(MyFileName).Close False
    MyFileName = Dir
Application.DisplayAlerts = True
Loop
End Sub

Sub ListFiles()
Dim MyPathName As String
Dim MyFileName As String
Dim NumChars As Long
Dim X As Long

    NumChars = 7 'Change this to the number of characters you want to return
    MyPathName = "C:\Users\copleyr\Desktop\All/" 'Change this to the folder you want to return
    MyFileName = Dir(MyPathName)
    Do While MyFileName <> ""
        X = X + 1
        Sheet1.Cells(X, 1) = Left(MyFileName, NumChars)
        MyFileName = Dir
    Loop
End Sub

Can anybody point me in the right direction of getting started? Thank you so much for your help in advance!

 

[wigi]

Updated and tested code:

Sub UpdateFiles()
    Const MyPathName As String = "C:\Users\copleyr\Desktop\All\"

    Dim MyFileName As String
    Dim wb As Workbook
    Dim lRow As Long

    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual

    With ThisWorkbook.Worksheets("Sheet1")

        For lRow = 2 To .Range("A" & .Rows.Count).End(xlUp).Row

            If Len(Trim(.Range("A" & lRow).Text)) Then

                Application.StatusBar = "Processing row " & lRow & "..."

                MyFileName = Dir(MyPathName & .Range("A" & lRow).Text & "*.xlsx")

                Do While Len(MyFileName) > 0

                    Set wb = Workbooks.Open(MyPathName & MyFileName, 0)

                    .Range("A" & lRow, "BN" & lRow).Copy Destination:=wb.Worksheets("Defaults").Range("A70")

                    wb.Close savechanges:=True

                    Set wb = Nothing

                    MyFileName = Dir

                Loop

            End If

        Next lRow

    End With

    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Application.StatusBar = False

    MsgBox "Ready.", vbInformation, "Status"

End Sub

 

[copleyr]

Works Perfectly! Thanks so much Wigi!!!

mrexcel...my savior once again!

 

[wigi]

Glad it's solved