Looking for a program to extract Excel data to txt files

  • Thread starter Thread starter Douglas
  • Start date Start date
D

Douglas

I have a collection of spreadsheets (over 1000) all based on an
invoice template.

Is there a program available somewhere to buy or free that will
extract certain specific cells and certain ranges to text files so i
can import them into a MS Access DB.
ie Cell K1 is the Date, K2 is the Cust Name, A10:A31 is the Invoice
Items, B10:B31 is the costs.

Once i get the information into plain text I will be able to do
everthing from then on. To do this manually would take weeks.

Im just looking for some automated way to extract the data from every
spreadsheet in a folder.

TIA

Doug
 
Douglas,

Try the code below, after you modify it where indicated. It will
extract the data in database format.

HTH,
Bernie
MS Excel MVP

Option Explicit

Sub ExtractLotsOfData()
Dim strPath As String
Dim strFName As String
Dim strShtName As String
Dim i As Integer
Dim myRow As Long

'Change this to your default sheet name
strShtName = "Sheet1"

With Application.FileSearch
.NewSearch
'Change the folder here
.LookIn = "C:\Excel\"
'Change this to False is you don't want to search subfolders
.SearchSubFolders = True
.FileType = msoFileTypeExcelWorkbooks
If .Execute() > 0 Then
MsgBox "There were " & .FoundFiles.Count & " file(s) found."
For i = 1 To .FoundFiles.Count
myRow = Range("A65536").End(xlUp)(2).Row
Cells(myRow, 1).Resize(22, 1).Value = .FoundFiles(i)
strPath = retPath(.FoundFiles(i))
strFName = retName(.FoundFiles(i))
Cells(myRow, 2).Resize(22, 1).Formula = _
"='" & strPath & "[" & strFName & "]" & strShtName & "'!$K$1"
Cells(myRow, 3).Resize(22, 1).Formula = _
"='" & strPath & "[" & strFName & "]" & strShtName & "'!$K$2"
'Extract A10:A31
Cells(myRow, 4).Resize(22, 1).Formula = _
"='" & strPath & "[" & strFName & "]" & strShtName & "'!A10"
'Extract B10:B31
Cells(myRow, 5).Resize(22, 1).Formula = _
"='" & strPath & "[" & strFName & "]" & strShtName & "'!B10"
With Range("A65536").End(xlUp).Offset(-21, 0)
.Resize(22, 5).Copy
.PasteSpecial xlPasteValues
End With
Next i
Else
MsgBox "There were no files found."
End If
End With
Application.CutCopyMode = False
Range("A1").Select
End Sub

Function retPath(strFullName As String) As String
retPath = Left(strFullName, InStrRev(strFullName, "\"))
End Function

Function retName(strFullName As String) As String
retName = Mid(strFullName, InStrRev(strFullName, "\") + 1, _
Len(strFullName))
End Function
 
Back
Top