Extracting data on multiple files from one folder

[Pawan]

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

 

[Don Guillett]

If desired, send your file to my address below. I will only look if:
1. You send a copy of this message on an inserted sheet
2. You give me the newsgroup and the subject line
3. You send a clear explanation of what you want
4. You send before/after examples and expected results.

 

[marcus]

Hi Pawan

This should do the trick. Place this code in a new module of a new
workbook. It will open all the files in a particular folder, identify
the unique values in column A of each sheet and return the workbook
name and sheet name to column A of "Sheet1" and the unique values
which correspond to this in Column B. You will need to change the
folder name and the sheet name if you want the result to appear
somewhere other than sheet1.

Take care

Marcus



Option Explicit
Sub GetUnique()
Dim oWbk As Workbook
Dim sFil As String
Dim sPath As String
Dim ws As Worksheet
Dim sh As Worksheet
Dim twbk As Workbook
Dim lw As Integer
Dim myVar As Integer
Dim lr As Integer
Dim MyShName As String
Dim myBkName As String

With Application
.ScreenUpdating = False
.EnableEvents = False
End With

Set twbk = ThisWorkbook

sPath = "C:\users\excel" 'location of files
ChDir sPath
sFil = Dir("*.xls") 'you can limit the search by adding data in
front or behind the *
On Error GoTo ExitProg
'Step Thru each worksheet in activeworkbook

Do While sFil <> "" 'opens the file read only
Set oWbk = Workbooks.Open(sPath & "\" & sFil,
ReadOnly:=True)

For Each ws In oWbk.Worksheets
ws.Activate
MyShName = ws.Name
myBkName = oWbk.Name
lw = Range("A" & Rows.Count).End(xlUp).Row
myVar = CountUniqueValues(Range("A1:A" & lw))
lr = twbk.Sheets("sheet1").Range("A" & Rows.Count).End
(xlUp).Row + 1
twbk.Sheets("sheet1").Range("B" & lr) = myVar
twbk.Sheets("sheet1").Range("A" & lr) = myBkName & " "
& MyShName

Next ws

oWbk.Close False
sFil = Dir
Set oWbk = Nothing
Loop

Set twbk = Nothing

ExitProg:

If Err > 0 Then
MsgBox (Error(Err))
Err.Clear

End If

End Sub

Function CountUniqueValues(InputRange As Range) As Long
Dim cl As Range, UniqueValues As New Collection
Application.Volatile
On Error Resume Next ' ignore any errors
For Each cl In InputRange
UniqueValues.Add cl.Value, CStr(cl.Value) ' add the unique
item
Next cl
On Error GoTo 0
CountUniqueValues = UniqueValues.Count
End Function

 

[joel]

this code put all the usique values into sheet1 of the workbook wher
the macro is located. change the Variable Folder as required.

Sub GetUnique()

NewRow = 1
Set RsltSht = ThisWorkbook.Sheets("Sheet1")

Folder = "c:\temp\"
FName = Dir(Folder & "*.xls")
Do While FName <> ""
Set bk = Workbooks.Open(Filename:=Folder & FName)
For Each sht In bk.Worksheets
With sht
LastRow = .Range("A" & Rows.Count).End(xlUp).Row
For RowCount = 1 To LastRow
Data = .Range("A" & RowCount)
If Data <> "" Then
'lookup if data already exists
Set c = RsltSht.Columns("A").Find(what:=Data, _
LookIn:=xlValues, lookat:=xlWhole)
If c Is Nothing Then
'data didn't already exist
RsltSht.Range("A" & NewRow) = Data
NewRow = NewRow + 1
End If
End If
Next RowCount
End With
Next sht
bk.Close savechanges:=False
FName = Dir()
Loop




End Su

 

[Barb Reinhardt]

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

 

[Barb Reinhardt]

If you want to loop through all worksheets in the opened workbook, change the

Set oWS = ... to

for each oWS in oWB.Worksheet

next oWS

And put all the action on oWS in that loop

 

[Pawan]

Thanks Barb,

I tried this macro on one test file in one folder. However the macro
execution never stops. It keeps on executing and I need to interrupt it. I
think it keeps on opening the same workbook again and again. I tried to debug
but could not...

Regards,
prm

 

[Barb Reinhardt]

Sorry about that. I forgot one important line. Before this line

Loop While myFile <> ""

put this

myFile = Dir

 

[Barb Reinhardt]

Sorry about that. I forgot one important line. Before this line

Loop While myFile <> ""

put this

myFile = Dir

 

[Barb Reinhardt]

Sorry about that. I forgot one important line. Before this line

Loop While myFile <> ""

put this

myFile = Dir

 

[Jacob Skaria]

Hi Pawan

The below macro would generate the unique list as a new sheet in your active
workbook. The macro would get data from all sheets of all workbooks present
in the folder. Launch VBE by hitting Alt+F11. From menu 'Insert' a module and
paste the below code. Get back to Workbook and run macro from Tools|Macro|Run
<selected macro()>. Please note that there is a subprocedure. Try and
feedback..

Sub GenerateUniqueList()
Dim strFolder As String, strFile As String, ws As Worksheet

'Browse folder
With Application.FileDialog(msoFileDialogFolderPicker)
If .Show = False Then MsgBox ("No folder selected"): End
strFolder = .SelectedItems(1) & "\"
End With

Set ws = ActiveWorkbook.Worksheets.Add(After:=ActiveSheet)
'Browse all files within the folder
Application.ScreenUpdating = False: Application.DisplayAlerts = False
strFile = Dir(strFolder & "*.xl*", vbNormal)
Do While strFile <> ""
OpenAndGetData strFolder & strFile, ws
strFile = Dir
Loop

'Generate unique list
ws.Range("A1") = "Unique List"
ws.Columns(1).Sort Key1:=ws.Range("A2"), Order1:=xlAscending, _
Header:=xlYes, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
ws.Columns(1).AdvancedFilter Action:=xlFilterCopy, _
CopyToRange:=ws.Range("B1"), Unique:=True
Columns(1).Delete
Application.ScreenUpdating = True: Application.DisplayAlerts = True
MsgBox "Unique list generated"
End Sub

Sub OpenAndGetData(strWBook As String, ws As Worksheet)
Dim wbTemp As Workbook, wsTemp As Worksheet, lngRow As Long
Set wbTemp = Workbooks.Open(strWBook, ReadOnly:=True)
For Each wsTemp In wbTemp.Sheets
lngRow = ws.Cells(Rows.Count, "A").End(xlUp).Row
wsTemp.Range("A1:A" & wsTemp.Cells(Rows.Count, _
"A").End(xlUp).Row).Copy ws.Range("A" & lngRow + 1)
Next
wbTemp.Close False
End Sub


If this post helps click Yes

 

[Joel]

I was the 1st one to respond to this posting a TheCodeCage.com to Pawan's
request put it was never seen at the microsoft website. If you look at the
ThecodeCage ther are 10 responses and at microsoft there are only 9. Mine is
missing.

Note: The codecage count is always different from microsoft because
thecodecage starts a 0 and microsoft starts at 1. the microsfot site is
broken again but differnt from the past. This time it is not posting
responses from ThecodeCage.

Sub GetUnique()

NewRow = 1
Set RsltSht = ThisWorkbook.Sheets("Sheet1")

Folder = "c:\temp\"
FName = Dir(Folder & "*.xls")
Do While FName <> ""
Set bk = Workbooks.Open(Filename:=Folder & FName)
For Each sht In bk.Worksheets
With sht
LastRow = .Range("A" & Rows.Count).End(xlUp).Row
For RowCount = 1 To LastRow
Data = .Range("A" & RowCount)
If Data <> "" Then
'lookup if data already exists
Set c = RsltSht.Columns("A").Find(what:=Data, _
LookIn:=xlValues, lookat:=xlWhole)
If c Is Nothing Then
'data didn't already exist
RsltSht.Range("A" & NewRow) = Data
NewRow = NewRow + 1
End If
End If
Next RowCount
End With
Next sht
bk.Close savechanges:=False
FName = Dir()
Loop

End Sub

 

[Jacob Skaria]

Hi Joel, I thought you were using the MS web..Responses through OutLook
Express are also not shown on the microsoft web interface...Its been in and
out for the last two weeks..

 

[joel]

I stopped using the MS site about 3 weeks ago when it broke. I started
noticing a few days ago at TheCodeCage that my code was being bypassed
for your code, Barb's, Dave and Chip's code. I then went back to MS and
found the response a made at CodeCage was not getting on the MS Site. I
now have to check to see if the postings at ThecodeCage originate from
MS or ThecodeCage to determine where I should make the response.
UGH!:nuts