extracting similar data from several workbooks

gta18

New Member
Joined
Apr 13, 2006
Messages
11
Hi, I have like a 100 workbooks with the same filename but different suffixes , i.e. payrollWE091506, payrollWE092206.. and so on. Each of this workbooks has a sheet named "weekly" and column 3 contains the project names like "val100", "ULT100" and column 1 contains the employee names. while column 4 contains hours worked for the project. I would like to make a macro or program that would open each of the workbooks and extract all the rows that contains ult100 and put it on another sheet or file?
thanks
arnold
 

Excel Facts

Round to nearest half hour?
Use =MROUND(A2,"0:30") to round to nearest half hour. Use =CEILING(A2,"0:30") to round to next half hour.

agihcam

Well-known Member
Joined
Jan 16, 2006
Messages
1,624
assuming all workbooks resides in drive C,
open new workbook, hit Alt + F11, insert a module and paste this code,
try ( untested );
Code:
Sub ult100()
ActiveWorkbook.Sheets(1).Cells.Delete
Application.ScreenUpdating = False
Application.DisplayAlerts = False

    'dimension variables
    Dim wb As Workbook, wsDest1 As Worksheet, wsDest2 As Worksheet
    Dim ws1 As Worksheet, Ws2 As Worksheet, i, ii As Long, Pos As Long
    Dim Folder As String, File As String, Path As String
    'folder to loop through
    Folder = "C:\" 'change to suit
    'set destination info
    Set wsDest1 = ActiveWorkbook.Sheets(1) '<<== is this correct?
    'Start FileSearch
    With Application.FileSearch
        .LookIn = Folder
        .Filename = "*.xls"
        .FileType = msoFileTypeExcelWorkbooks
        .SearchSubFolders = False
        .Execute
        If .Execute > 0 Then
            'loop through all found files
            For i = 1 To .FoundFiles.Count
                'set incidental variables
                Pos = InStrRev(.FoundFiles(i), "\")
                File = Right(.FoundFiles(i), Len(.FoundFiles(i)) - Pos)
                Path = Left(.FoundFiles(i), Pos)
                'check if workbook is open.  if so, set variable to it, else open it
                If IsWbOpen(File) Then
                    Set wb = Workbooks(File)
                Else
                    Set wb = Workbooks.Open(Path & File)
                End If
                'set worksheets to copy data from
                Set ws1 = wb.Sheets("weekly")
                'copy data
               For ii = 1 To ws1.Range("c" & Rows.Count).End(xlUp).Row
                If UCase(ws1.Cells(ii, "c")) = "ULT100" Then
                    wsDest1.Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(, 4) = ws1.Cells(ii, "a").Resize(, 4).Value
                        End If
                Next
                wb.Close
            Next i
        End If
    End With
    
    Set wsDest1 = Nothing: Set wsDest2 = Nothing: Set ws1 = Nothing
    Set Ws2 = Nothing: Set wb = Nothing

Application.ScreenUpdating = False
Application.DisplayAlerts = False
End Sub
Function IsWbOpen(wbName As String) As Boolean
    On Error Resume Next
    IsWbOpen = Len(Workbooks(wbName).Name)
End Function
 

gta18

New Member
Joined
Apr 13, 2006
Messages
11

ADVERTISEMENT

thanks, I'll try it today....
 

gta18

New Member
Joined
Apr 13, 2006
Messages
11
iT WORKED GREAT! thanks, but i have another q,(all of the workbooks are in one folder) I have a problem on the workbooks, cause not all of the workbooks have the first sheet named "weekly"

q's

1.) how do I rename all of the first sheet on all of the workbooks to "weekly"

2.) how do i add the last 10 characters of the filename where the row came for to the last column of the extracted row?

3.) what if I wanted it to look for the files beggining with "payrollsummaryweekly" ?

4.) if i only want to extract the row if the 30th column is not 0

for having too much q's am just starting to learn excel and vb.
thanks:)
 

agihcam

Well-known Member
Joined
Jan 16, 2006
Messages
1,624
1.) how do I rename all of the first sheet on all of the workbooks to "weekly"
If the data you need to copy was in the first sheet, you dont need to rename the first sheet of every workbook to "weekly", instead you can directly change the code like this;
from;
Code:
Set ws1 = wb.Sheets("weekly")
to;
Code:
Set ws1 = wb.Sheets(1)

[/quote]
2.) how do i add the last 10 characters of the filename where the row came for to the last column of the extracted row?
This line of code will add the 10 characters before ".xls" on the filename where the rows came from;
Code:
'copy data
               For ii = 1 To ws1.Range("c" & Rows.Count).End(xlUp).Row
                If UCase(ws1.Cells(ii, "c")) = "ULT100" Then
                    wsDest1.Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(, 4) = ws1.Cells(ii, "a").Resize(, 4).Value
                    wsDest1.Cells(Rows.Count, 1).End(xlUp).Offset(, 4) = Mid(File, InStr(File, ".") - 10, 10) 'this line add the 10 characters of the filename

                        End If
                Next

3.) what if I wanted it to look for the files beggining with "payrollsummaryweekly" ?
this code will do;
Code:
If File Like "payrollsummaryweekly*" Then 'add this line
                If IsWbOpen(File) Then.
.
.
wb.Close
                End If 'add this line
4.) if i only want to extract the row if the 30th column is not 0
this code will do;
Code:
   If UCase(ws1.Cells(ii, "c")) = "ULT100" And ws1.Cells(ii, "ad") > 0 Then

hope it helps.
 

Forum statistics

Threads
1,137,205
Messages
5,680,174
Members
419,887
Latest member
Vasokir

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top