Import data, paste to next empty row and then delete source data

[sharky12345]

This may be a big ask but worth a try.....

I'd like to adapt this code to do the following if someone can help;

1) Instead of prompting for the file location, I need it to loop through all subfolders from where the active workbook sits and search for any .xls file that contains the phrase 'Log Book' in the filename - if it is found then continue the import, if not then move on to the next subfolder
2) After copying data from the source file, paste to the next empty row in column A
3) Delete the values only from the source file
4) Close the source file, saving changes
5) Surpress the message that says there is data on the clipboard

Sub ImportData()

Dim Evnt As String
Dim SourceFile As Workbook
Dim filePath As String
Dim fileName As String
FileToOpen = Application.GetOpenFilename(FileFilter:="Excel Files (*.xls), *.xls")
filePath = Left$(FileToOpen, InStrRev(FileToOpen, "\"))
fileName = Mid$(FileToOpen, InStrRev(FileToOpen, "\") + 1)
'Application.ScreenUpdating = False
Application.EnableEvents = False
Set SourceFile = Workbooks.Open(fileName:=FileToOpen)
SourceFile.Sheets("Data").Activate
With SourceFile.Sheets("Data")
Range("A2:J2").Select
Range(Selection, Selection.End(xlDown)).Select
Application.CutCopyMode = False
Selection.Copy
End With
ThisWorkbook.Sheets("DataImport").Range("A").PasteSpecial Paste:=xlValues

End Sub

Even if someone can help with part of the list that will be progress.....

 

[BarryL]

Hi sharky,

going home now so couldnt look too much into this. the following needs to use the Microsoft Scripting Runtime Library. so add it as a reference if you dont already have it. Then the below will cycle through all the workbooks and if it is a .xls it will move to the Then part of the IF. just not quite sure how to open it then. I think this is the start of what you want to do? I'll try have a look at it more tonight if it is.

Sub ListFilesInFolder()
     
     
    Dim FS As Scripting.FileSystemObject
    Dim SourceFolder As Scripting.Folder
    Dim FileItem As Scripting.File
    Dim r As Long
    Set FS = New Scripting.FileSystemObject
    Set SourceFolder = FS.GetFolder("C:\") 'Place in here the directory of interest
    For Each FileItem In SourceFolder.Files
       If FileItem.Type = "Microsoft Excel Worksheet" Then
    Next FileItem
End Sub

 

[BarryL]

for example try

Sub ListFilesInFolder()
     
     
    Dim FS As Scripting.FileSystemObject
    Dim SourceFolder As Scripting.Folder
    Dim FileItem As Scripting.File
    Dim r As Long
    Set FS = New Scripting.FileSystemObject
    Set SourceFolder = FS.GetFolder("C:\") 'Place in here the directory of interest
    For Each FileItem In SourceFolder.Files
       msgbox fileitem.type
    Next FileItem
End Sub

 

[sharky12345]

BarryL, thanks!

I haven't got time to look tonight but will do so tomorrow - thanks for the start!

 

[BarryL]

ADVERTISEMENT

I got a .xls file to open using this

Sub ListFilesInFolder()
     
     
    Dim FS As Scripting.FileSystemObject
    Dim SourceFolder As Scripting.Folder
    Dim FileItem As Scripting.File
    Dim r As Long
    Set FS = New Scripting.FileSystemObject
    Set SourceFolder = FS.GetFolder("C:\......\") 'Place in here the directory of interest
    For Each FileItem In SourceFolder.Files
       If FileItem.Type = "Microsoft Excel Worksheet" Then
       FileItem.Copy FileItem.Name, True
       Application.Workbooks.Open (FileItem.Name)
       End If
    Next FileItem
End Sub

 

[sharky12345]

Thanks, will give this a try late to see if I can deal with part of the problem.

 

[sharky12345]

Can anyone offer some assistance in solving the other parts of the list?