View Single Post
  #5   Report Post  
Posted to microsoft.public.excel.programming
Barb Reinhardt Barb Reinhardt is offline
external usenet poster
 
Posts: 3,355
Default Extracting data on multiple files from one folder

Try this. Keep in mind that this is completely untested. I did create a new
workbook to save the data to. You can modify as needed.

Option Explicit
Option Base 1

Sub OpenAndCountUnique()
Dim myUnique() As Variant
Dim r As Excel.Range
Dim myRange As Excel.Range
Dim oWB As Excel.Workbook
Dim myFolder As String
Dim myFile As String
Dim aWB As Excel.Workbook
Dim aWS As Excel.Worksheet
Dim oWS As Excel.Worksheet
Dim i As Long
Dim oWSlRow As Long
Dim aWSlRow As Long
Dim myCell As Excel.Range
Dim myCount As Long
Dim Match As Boolean

With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
If .Show = False Then
MsgBox ("No folder selected. Execution ending.")
End
End If
myFolder = .SelectedItems(1)
End With

myFolder = myFolder & "\"

myFile = Dir(myFolder & "*.x*")

If myFile = "" Then
MsgBox ("There are no excel files in the selected folder. Execution
ending.")
End
End If

myCount = 0
On Error Resume Next
myCount = UBound(myUnique)
On Error GoTo 0

Do
Set oWB = Workbooks.Open(myFolder & myFile, Readonly:= True)
'selects first worksheet in file, change as needed
Set oWS = oWB.Worksheets(1)

'Determines last row on oWS column 1. Change as needed
oWSlRow = oWS.Cells(oWS.Rows.Count, 1).End(xlUp).Row
For i = 1 To oWSlRow
Set myCell = oWS.Cells(i, 1)
If Not IsEmpty(myCell) Then
If myCount = 0 Then
myCount = myCount + 1
ReDim Preserve myUnique(myCount)
myUnique(myCount) = myCell.Text
Else
Match = False
For j = 1 To myCount
If LCase(myUnique(j)) = LCase(myCell.Text) Then
Match = True
Exit For
End If
Next j
If Not Match Then
myCount = myCount + 1
ReDim Preserve myUnique(myCount)
myUnique(myCount) = myCell.Text
End If
End If
Next i


oWB.Close

Loop While myFile < ""

myCount = UBound(myUnique)

If myCount 0 Then
'Created a new workbook
Set aWB = Workbooks.Add
Set aWS = aWB.Worksheets(1) 'Saves to first worksheet

For i = 1 To myCount
aWSlRow = i 'You may want to add a header and change this #
aWS.Cells(aWSlRow, 1).Value = myUnique(i)
Next i

End If

End Sub


HTH,
Barb Reinhardt


"Pawan" wrote:

Hello

I have a folder with several excel files in it. I want to write a macro in
new workbook. This macro should count the number of used 'unique' cells from
column "A" of all the excel sheets. The result should be added in one sheet
of the book (in which macro is written).

Thank You

Regards,
prm