Keep in mind the following instructions:
1. "Source" sheet is the file that contains your database
2. You wil have to add a blank sheet to workbook and name it Destination
3. .pdf and .xlsx and more are the extensions extracted to Destination using this code.
4. Run the code once, all .pdf extension files will be xtracted to Destination, then run the same code again, all .xlsx will be extracted to Destination below the .pdf's
Sub Extraction()
Dim xRg As Range
Dim xCell As Range
Dim I As Long
Dim J As Long
I = Worksheets("Source").UsedRange.Rows.Count
J = Worksheets("Destination").UsedRange.Rows.Count
If J = 1 Then
If Application.WorksheetFunction.CountA(Worksheets("Destination").UsedRange) = 0 Then J = 0
End If
Set xRg = Worksheets("Source").Range("F2:F" & I)
On Error Resume Next
Application.ScreenUpdating = False
For Each xCell In xRg
If CStr(xCell.Value) = ".pdf" Or CStr(xCell.Value) = ".xlsx" Or CStr(xCell.Value) = ".xls" Or CStr(xCell.Value) = ".doc" Or CStr(xCell.Value) = ".docx" Then
xCell.EntireRow.Copy Destination:=Worksheets("Destination").Range("A" & J + 1)
xCell.EntireRow.Delete
J = J + 1
End If
Next
Application.ScreenUpdating = True
End Sub
Code Snips for re-use
To Search for Extensions in bulk
Sub ConvertWordsToPdfs()
Dim directory As String
directory = "C:\Wordup" ' The starting directory
Dim fso, newFile, folder, files
Set fso = CreateObject("Scripting.FileSystemObject")
Set folder = fso.GetFolder(directory)
Set files = folder.files
For Each file In files
Dim newName As String
newName = Replace(file.Path, ".doc", ".pdf")
Documents.Open FileName:=file.Path, _
ConfirmConversions:=False, ReadOnly:=False, AddToRecentFiles:=False, _
PasswordDocument:="", PasswordTemplate:="", Revert:=False, _
WritePasswordDocument:="", WritePasswordTemplate:="", Format:= _
wdOpenFormatAuto, XMLTransform:=""
ActiveDocument.ExportAsFixedFormat OutputFileName:=newName, _
ExportFormat:=wdExportFormatPDF, OpenAfterExport:=False, OptimizeFor:= _
wdExportOptimizeForPrint, Range:=wdExportAllDocument, From:=1, To:=1, _
Item:=wdExportDocumentContent, IncludeDocProps:=True, KeepIRM:=True, _
CreateBookmarks:=wdExportCreateNoBookmarks, DocStructureTags:=True, _
BitmapMissingFonts:=True, UseISO19005_1:=False
ActiveDocument.Close
Next
End Sub
OPENING MULTIPLE FILES
Sub OpenMultipleFiles()
Dim Filter As String, Title As String, msg As String
Dim i As Integer, FilterIndex As Integer
Dim Filename As Variant
' File filters
Filter = "Excel Files (*.xls),*.xls," & _
"Text Files (*.txt),*.txt," & _
"All Files (*.*),*.*"
' Default filter to *.*
FilterIndex = 3
' Set Dialog Caption
Title = "Select File(s) to Open"
' Select Start Drive & Path
ChDrive ("E")
ChDir ("E:\Chapters\chap14")
With Application
' Set File Name Array to selected Files (allow multiple)
Filename = .GetOpenFilename(Filter, FilterIndex, Title, , True)
' Reset Start Drive/Path
ChDrive (Left(.DefaultFilePath, 1))
ChDir (.DefaultFilePath)
End With
' Exit on Cancel
If Not IsArray(Filename) Then
MsgBox "No file was selected."
Exit Sub
End If
' Open Files
For i = LBound(Filename) To UBound(Filename)
msg = msg & Filename(i) & vbCrLf ' This can be removed
Workbooks.Open Filename(i)
Next i
MsgBox msg, vbInformation, "Files Opened"' This can be removed
End Sub
Solved by G. Y. in 23 mins