Extracting data from excel VBA

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

Code:

---

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

---

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

Code:

---

Const ListCol As String = "L" 'Edit to suit your needs

---

Add to Sub ExtracData before FileName = Dir

Code:

---

Columns (ListCol).Cells(1) = ThisWorkbook.Name

---

Change:

Code:

---

If fileName <> ThisWorkbook.Name Then

---

To

Code:

---

If Not Listed(FileName) Then
  Cells(Rows.Count, ListCol).End(xlUp).Offset(1) = FileName

---

Add New Function

Code:

---

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

---

Quote:

---

Originally Posted by 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

Code:

---

Const ListCol As String = "L" 'Edit to suit your needs

---

Add to Sub ExtracData before FileName = Dir

Code:

---

Columns (ListCol).Cells(1) = ThisWorkbook.Name

---

Change:

Code:

---

If fileName <> ThisWorkbook.Name Then

---

To

Code:

---

If Not Listed(FileName) Then
  Cells(Rows.Count, ListCol).End(xlUp).Offset(1) = FileName

---

Add New Function

Code:

---

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.