Match or Lookup

[K]

Hi all, I am using excel 2007. I have list of files names in column A
of Sheet1 like (see below)

A ------column
Record A
Record B
Record C
etc….

All the names listed in column A are the names of the files which are
in Folder "C:\Document\Data". I want macro assigned to a button in
Sheet1 which should Match or Lookup files names listed in column A of
Sheet1 with names of files which are in above Folder. And if there
are new files been saved in Folder which names are not listed in
column A of Sheet1 then macro should open them one by one and copy
cell B2 value from those files and paste it in column B of Sheet1 and
Put that file name without extension below the last value cell of
column A and then close those files. Please can any friend can help
as i need simple and small macro if possible and i been asking this
question from two weeks but didnt have any accurate answer.

 

[Joel]

I didn't see this posting before. It is very simple

Sub getfiles()

Folder = "C:\Document\Data\"


FName = Dir(Folder & "*.xls")

LastRow = Range("A" & Rows.Count).End(xlUp).Row
NewRow = LastRow + 1

Do While FName <> ""
Set c = Columns("A").Find(what:=FName, _
LookIn:=xlValues, lookat:=xlWhole)
If c Is Nothing Then
Set bk = Workbooks.Open(Filename:=Folder & FName)
With bk.Sheets(1)
Data = .Range("B2")
.Range("A" & NewRow) = FName
.Range("B" & NewRow) = Data
NewRow = NewRow + 1
End With
bk.Close savechanges:=False
End If

FName = Dir()
Loop


End Sub

 

[Per Jessen]

Hi

Insert this code in an ordinary module and call it from the
CommandButton. As I assume there is only Excel files in the directory,
the macro doesn't check the file type. This will cause an error if I
am wrong, but the test can be incorporated in this code.

Sub AAA()
Dim wbA As Workbook
Dim wbB As Workbook
Dim shA As Worksheet
Dim shB As Worksheet
Dim TargetRange As Range
Dim FileNam As String
Dim FileNam1 As String
Dim TargetFol As String

Set wbA = ActiveWorkbook
Set shA = wbA.Worksheets("Sheet1")
TargetFol = "C:\Document\Data\"

FileNam = Dir(TargetFol)

Do Until FileNam = ""
Set TargetRange = shA.Range("A1", shA.Range("A1").End(xlDown))
FileNam1 = Left(FileNam, WorksheetFunction.Find(".", FileNam) - 1)
Set f = TargetRange.Find(what:=FileNam1, lookat:=xlWhole)
If f Is Nothing Then
Set wbB = Workbooks.Open(Filename:=TargetFol & FileNam)
Set shB = wbB.Worksheets("Sheet1")
DestRow = shA.Range("A1").End(xlDown).Row + 1
shB.Range("B2").Copy shA.Range("B" & DestRow)
shA.Range("A" & DestRow) = FileNam1
wbB.Close
End If
FileNam = Dir
Loop
End Sub

Regards,
Per

 

[K]

I didn't see this posting before.  It is very simple

Sub getfiles()

Folder = "C:\Document\Data\"

FName = Dir(Folder & "*.xls")

LastRow = Range("A" & Rows.Count).End(xlUp).Row
NewRow = LastRow + 1

Do While FName <> ""
   Set c = Columns("A").Find(what:=FName, _
      LookIn:=xlValues, lookat:=xlWhole)
   If c Is Nothing Then
      Set bk = Workbooks.Open(Filename:=Folder & FName)
      With bk.Sheets(1)
         Data = .Range("B2")
         .Range("A" & NewRow) = FName
         .Range("B" & NewRow) = Data
         NewRow = NewRow + 1
      End With
      bk.Close savechanges:=False
   End If

   FName = Dir()
Loop

End Sub







- Show quoted text -

thanks

 

[K]

I didn't see this posting before.  It is very simple

Sub getfiles()

Folder = "C:\Document\Data\"

FName = Dir(Folder & "*.xls")

LastRow = Range("A" & Rows.Count).End(xlUp).Row
NewRow = LastRow + 1

Do While FName <> ""
   Set c = Columns("A").Find(what:=FName, _
      LookIn:=xlValues, lookat:=xlWhole)
   If c Is Nothing Then
      Set bk = Workbooks.Open(Filename:=Folder & FName)
      With bk.Sheets(1)
         Data = .Range("B2")
         .Range("A" & NewRow) = FName
         .Range("B" & NewRow) = Data
         NewRow = NewRow + 1
      End With
      bk.Close savechanges:=False
   End If

   FName = Dir()
Loop

End Sub







- Show quoted text -

just small question that how can i change the code if files are in
subfolders

 

[Joel]

I'm not sure if you want to search both main folder and subfolder. I only
did subfolders. Also I'm just searching for the basic filename (doesn't
include folders) when looking for file on the worksheet.

Sub getfiles()

FolderName = "C:\Document\Data"
FolderName = "C:\Temp"

Set fs = CreateObject("Scripting.FileSystemObject")
Set Folder = fs.GetFolder(FolderName)

LastRow = Range("A" & Rows.Count).End(xlUp).Row
NewRow = LastRow + 1

For Each Subfld In Folder.subfolders

FName = Dir(Subfld & "\" & "*.xls")

Do While FName <> ""
Set c = Columns("A").Find(what:=FName, _
LookIn:=xlValues, lookat:=xlWhole)
If c Is Nothing Then
Set bk = Workbooks.Open(Filename:=Subfld & "\" & FName)
With bk.Sheets(1)
Data = .Range("B2")
.Range("A" & NewRow) = FName
.Range("B" & NewRow) = Data
NewRow = NewRow + 1
End With
bk.Close savechanges:=False
End If

FName = Dir()
Loop
Next Subfld

End Sub

 

[K]

I'm not sure if you want to search both main folder and subfolder.  I only
did subfolders.  Also I'm just searching for the basic filename (doesn't
include folders) when looking for file on the worksheet.

Sub getfiles()

FolderName = "C:\Document\Data"
FolderName = "C:\Temp"

Set fs = CreateObject("Scripting.FileSystemObject")
Set Folder = fs.GetFolder(FolderName)

LastRow = Range("A" & Rows.Count).End(xlUp).Row
NewRow = LastRow + 1

For Each Subfld In Folder.subfolders

   FName = Dir(Subfld & "\" & "*.xls")

   Do While FName <> ""
      Set c = Columns("A").Find(what:=FName, _
         LookIn:=xlValues, lookat:=xlWhole)
      If c Is Nothing Then
         Set bk = Workbooks.Open(Filename:=Subfld & "\" & FName)
         With bk.Sheets(1)
            Data = .Range("B2")
            .Range("A" & NewRow) = FName
            .Range("B" & NewRow) = Data
            NewRow = NewRow + 1
         End With
         bk.Close savechanges:=False
      End If

      FName = Dir()
   Loop
Next Subfld

End Sub






- Show quoted text -

Thats brilliant Joel. Thanks lot