Extracting data from excel VBA

[leemcder]

Hi everyone, hoping someone can help me with a problem I've got.

The code below extracts data from multiple excel spreadsheets in a folder, works great for that. We than add extra data etc ourselves.

What I'd like is also an option to update the data, so any new excel documents added to the folder since the macro was run last run it will just add those to the bottom of the existing data. (I don't want to clear the data and populate the whole data again as we would lose any extra data we have added ourselves) Is anyone able to help with that please?

Many thanks


Sub ExtracData()

Dim summary As Workbook
Dim wb As Workbook
Dim directory As String
Dim fileName As String
Dim NextRow As Long




Application.DisplayAlerts = False
Application.ScreenUpdating = False


Set summary = ThisWorkbook
directory = summary.Worksheets("Sheet1").Range("A1")
fileName = Dir(directory & "*.xl??")


Do While fileName <> ""
If fileName <> ThisWorkbook.Name Then
Set wb = Workbooks.Open(directory & fileName)
wb.Worksheets("data").Range("A1:G1").Copy
summary.Activate
NextRow = Cells(Rows.Count, "A").End(xlUp).Row + 1
Worksheets("Sheet1").Range("A" & NextRow).Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
wb.Close savechanges:=False
End If
fileName = Dir
Loop


Application.DisplayAlerts = True
Application.ScreenUpdating = True




MsgBox "Updated"


End Sub

[SamT]

You will need that Sub to keep a list of files already extracted and add a function to it that ignores any file already listed

One method is:
Declare Module level Constant
Const ListCol As String = "L" 'Edit to suit your needs

Add to Sub ExtracData before FileName = Dir
Columns (ListCol).Cells(1) = ThisWorkbook.Name

Change:
If fileName <> ThisWorkbook.Name Then
To
If Not Listed(FileName) Then
Cells(Rows.Count, ListCol).End(xlUp).Offset(1) = FileName

Add New Function

Private Function Listed(FileName As String) As Boolean
Dim List As Variant
Dim i as Long

List = Cells(1, ListCol).CurrentRegion.Value 'CurrentRegion require List of File Names be surrounded by empty cells

For i = 1 to Ubound(List)
If List(i) = FileName Then
Listed = True
Exit Function
End If
Next i
End Function

[leemcder]

You will need that Sub to keep a list of files already extracted and add a function to it that ignores any file already listed

One method is:
Declare Module level Constant
Const ListCol As String = "L" 'Edit to suit your needs

Add to Sub ExtracData before FileName = Dir
Columns (ListCol).Cells(1) = ThisWorkbook.Name

Change:
If fileName <> ThisWorkbook.Name Then
To
If Not Listed(FileName) Then
Cells(Rows.Count, ListCol).End(xlUp).Offset(1) = FileName

Add New Function

Private Function Listed(FileName As String) As Boolean
Dim List As Variant
Dim i as Long

List = Cells(1, ListCol).CurrentRegion.Value 'CurrentRegion require List of File Names be surrounded by empty cells

For i = 1 to Ubound(List)
If List(i) = FileName Then
Listed = True
Exit Function
End If
Next i
End Function

Thank you for your help. I have also found an alternative work around. I added code at the end which deletes the .xlsx documents from the directory folder. This only leaves new .xlsx documents the next time the macro is run.