Excel VBA Extracting data from other workbooks

J

jmancha

New Member
Joined
Feb 8, 2012
Messages
20
Good afternoon and Happy Friday!

I found and modified a macro many, many moons ago that takes the data from the first row and certain columns of a group of excel workbooks and creates one excel file with all of the data. It works FABULOUS however I do not really know how it works. I now need to extract the data from ONE cell on a sheet in about 500 workbooks BUT the data, unlike my current data, is not the first sheet in the workbook and I am lost. I am sure the macro has a place to specify which worksheet o look at but I cannot find it. :(

I have pasted the macro below and would appreciate any help!

Code: 
[FONT=Cambria][SIZE=3][COLOR=#000000]Private Declare Function SetCurrentDirectoryA Lib _[/COLOR][/SIZE][/FONT]

[FONT=Cambria][SIZE=3][COLOR=#000000]   "jen20" (ByVal lpPathName As String) As Long[/COLOR][/SIZE][/FONT]


[FONT=Cambria][SIZE=3][COLOR=#000000]Sub ChDirNet(szPath As String)[/COLOR][/SIZE][/FONT]
[FONT=Cambria][SIZE=3][COLOR=#000000]   SetCurrentDirectoryA szPath[/COLOR][/SIZE][/FONT]
[FONT=Cambria][SIZE=3][COLOR=#000000]End Sub[/COLOR][/SIZE][/FONT]


[FONT=Cambria][SIZE=3][COLOR=#000000]Sub MergeSpecificWorkbooks()[/COLOR][/SIZE][/FONT]
[FONT=Cambria][SIZE=3][COLOR=#000000]    Dim MyPath AsString[/COLOR][/SIZE][/FONT]
[FONT=Cambria][SIZE=3][COLOR=#000000]    Dim SourceRcountAs Long, FNum As Long[/COLOR][/SIZE][/FONT]
[FONT=Cambria][SIZE=3][COLOR=#000000]    Dim mybook AsWorkbook, BaseWks As Worksheet[/COLOR][/SIZE][/FONT]
[FONT=Cambria][SIZE=3][COLOR=#000000]    Dim sourceRange AsRange, destrange As Range[/COLOR][/SIZE][/FONT]
[FONT=Cambria][SIZE=3][COLOR=#000000]    Dim rnum As Long,CalcMode As Long[/COLOR][/SIZE][/FONT]
[FONT=Cambria][SIZE=3][COLOR=#000000]    Dim SaveDriveDirAs String[/COLOR][/SIZE][/FONT]
[FONT=Cambria][SIZE=3][COLOR=#000000]    Dim FName AsVariant[/COLOR][/SIZE][/FONT]


[FONT=Cambria][SIZE=3][COLOR=#000000]    ' Set applicationproperties.[/COLOR][/SIZE][/FONT]
[FONT=Cambria][SIZE=3][COLOR=#000000]    With Application[/COLOR][/SIZE][/FONT]
[FONT=Cambria][SIZE=3][COLOR=#000000]        CalcMode =.Calculation[/COLOR][/SIZE][/FONT]
[FONT=Cambria][SIZE=3][COLOR=#000000]        .Calculation =xlCalculationManual[/COLOR][/SIZE][/FONT]
[FONT=Cambria][SIZE=3][COLOR=#000000]       .ScreenUpdating = False[/COLOR][/SIZE][/FONT]
[FONT=Cambria][SIZE=3][COLOR=#000000]        .EnableEvents= False[/COLOR][/SIZE][/FONT]
[FONT=Cambria][SIZE=3][COLOR=#000000]    End With[/COLOR][/SIZE][/FONT]

[FONT=Cambria][SIZE=3][COLOR=#000000]    SaveDriveDir =CurDir[/COLOR][/SIZE][/FONT]
[FONT=Cambria][SIZE=3][COLOR=#000000]    ' Change this tothe path\folder location of the files.[/COLOR][/SIZE][/FONT]
[FONT=Cambria][SIZE=3][COLOR=#000000]    ChDirNet"U:\Test Folder"[/COLOR][/SIZE][/FONT]

[FONT=Cambria][SIZE=3][COLOR=#000000]    FName =Application.GetOpenFilename(filefilter:="Excel Files (*.xl*), *.xl*",_[/COLOR][/SIZE][/FONT]
[FONT=Cambria][SIZE=3][COLOR=#000000]                                       MultiSelect:=True)[/COLOR][/SIZE][/FONT]
[FONT=Cambria][SIZE=3][COLOR=#000000]    If IsArray(FName)Then[/COLOR][/SIZE][/FONT]

[FONT=Cambria][SIZE=3][COLOR=#000000]        ' Add a newworkbook with one sheet.[/COLOR][/SIZE][/FONT]
[FONT=Cambria][SIZE=3][COLOR=#000000]        Set BaseWks =Workbooks.Add(xlWBATWorksheet).Worksheets(1)[/COLOR][/SIZE][/FONT]
[FONT=Cambria][SIZE=3][COLOR=#000000]        rnum = 1[/COLOR][/SIZE][/FONT]


[FONT=Cambria][SIZE=3][COLOR=#000000]        ' Loop throughall files in the myFiles array.[/COLOR][/SIZE][/FONT]
[FONT=Cambria][SIZE=3][COLOR=#000000]        For FNum =LBound(FName) To UBound(FName)[/COLOR][/SIZE][/FONT]
[FONT=Cambria][SIZE=3][COLOR=#000000]            Set mybook= Nothing[/COLOR][/SIZE][/FONT]
[FONT=Cambria][SIZE=3][COLOR=#000000]            On ErrorResume Next[/COLOR][/SIZE][/FONT]
[FONT=Cambria][SIZE=3][COLOR=#000000]            Set mybook= Workbooks.Open(FName(FNum))[/COLOR][/SIZE][/FONT]
[FONT=Cambria][SIZE=3][COLOR=#000000]            On ErrorGoTo 0[/COLOR][/SIZE][/FONT]

[FONT=Cambria][SIZE=3][COLOR=#000000]            If Notmybook Is Nothing Then[/COLOR][/SIZE][/FONT]

[FONT=Cambria][SIZE=3][COLOR=#000000]                OnError Resume Next[/COLOR][/SIZE][/FONT]
[FONT=Cambria][SIZE=3][COLOR=#000000]                Withmybook.Worksheets(1)[/COLOR][/SIZE][/FONT]
[FONT=Cambria][SIZE=3][COLOR=#000000]                    Set sourceRange =.Range("A2:ZZ2")[/COLOR][/SIZE][/FONT]
[FONT=Cambria][SIZE=3][COLOR=#000000]                EndWith[/COLOR][/SIZE][/FONT]

[FONT=Cambria][SIZE=3][COLOR=#000000]                IfErr.Number > 0 Then[/COLOR][/SIZE][/FONT]
[FONT=Cambria][SIZE=3][COLOR=#000000]                   Err.Clear[/COLOR][/SIZE][/FONT]
[FONT=Cambria][SIZE=3][COLOR=#000000]                   Set sourceRange = Nothing[/COLOR][/SIZE][/FONT]
[FONT=Cambria][SIZE=3][COLOR=#000000]                Else[/COLOR][/SIZE][/FONT]
[FONT=Cambria][SIZE=3][COLOR=#000000]                    'If the source range uses all columns then[/COLOR][/SIZE][/FONT]
[FONT=Cambria][SIZE=3][COLOR=#000000]                    'skip this file.[/COLOR][/SIZE][/FONT]
[FONT=Cambria][SIZE=3][COLOR=#000000]                    IfsourceRange.Columns.Count >= BaseWks.Columns.Count Then[/COLOR][/SIZE][/FONT]
[FONT=Cambria][SIZE=3][COLOR=#000000]                       Set sourceRange = Nothing[/COLOR][/SIZE][/FONT]
[FONT=Cambria][SIZE=3][COLOR=#000000]                   End If[/COLOR][/SIZE][/FONT]
[FONT=Cambria][SIZE=3][COLOR=#000000]                End If[/COLOR][/SIZE][/FONT]
[FONT=Cambria][SIZE=3][COLOR=#000000]                OnError GoTo 0[/COLOR][/SIZE][/FONT]

[FONT=Cambria][SIZE=3][COLOR=#000000]                If NotsourceRange Is Nothing Then[/COLOR][/SIZE][/FONT]

[FONT=Cambria][SIZE=3][COLOR=#000000]                   SourceRcount = sourceRange.Rows.Count[/COLOR][/SIZE][/FONT]

[FONT=Cambria][SIZE=3][COLOR=#000000]                    Ifrnum + SourceRcount >= BaseWks.Rows.Count Then[/COLOR][/SIZE][/FONT]
[FONT=Cambria][SIZE=3][COLOR=#000000]                       MsgBox "There are not enough rows in the target worksheet."[/COLOR][/SIZE][/FONT]
[FONT=Cambria][SIZE=3][COLOR=#000000]                       BaseWks.Columns.AutoFit[/COLOR][/SIZE][/FONT]
[FONT=Cambria][SIZE=3][COLOR=#000000]                       mybook.Close savechanges:=False[/COLOR][/SIZE][/FONT]
[FONT=Cambria][SIZE=3][COLOR=#000000]                       GoTo ExitTheSub[/COLOR][/SIZE][/FONT]
[FONT=Cambria][SIZE=3][COLOR=#000000]                   Else[/COLOR][/SIZE][/FONT]

[FONT=Cambria][SIZE=3][COLOR=#000000]                       ' Copy the file name in column A.[/COLOR][/SIZE][/FONT]
[FONT=Cambria][SIZE=3][COLOR=#000000]                       With sourceRange[/COLOR][/SIZE][/FONT]
[FONT=Cambria][SIZE=3][COLOR=#000000]                           BaseWks.Cells(rnum, "A"). _[/COLOR][/SIZE][/FONT]
[FONT=Cambria][SIZE=3][COLOR=#000000]                                   Resize(.Rows.Count).Value = FName(FNum)[/COLOR][/SIZE][/FONT]
[FONT=Cambria][SIZE=3][COLOR=#000000]                       End With[/COLOR][/SIZE][/FONT]

[FONT=Cambria][SIZE=3][COLOR=#000000]                       ' Set the destination range.[/COLOR][/SIZE][/FONT]
[FONT=Cambria][SIZE=3][COLOR=#000000]                       Set destrange = BaseWks.Range("B" & rnum)[/COLOR][/SIZE][/FONT]

[FONT=Cambria][SIZE=3][COLOR=#000000]                       ' Copy the values from the source range[/COLOR][/SIZE][/FONT]
[FONT=Cambria][SIZE=3][COLOR=#000000]                       ' to the destination range.[/COLOR][/SIZE][/FONT]
[FONT=Cambria][SIZE=3][COLOR=#000000]                       With sourceRange[/COLOR][/SIZE][/FONT]
[FONT=Cambria][SIZE=3][COLOR=#000000]                           Set destrange = destrange. _[/COLOR][/SIZE][/FONT]
[FONT=Cambria][SIZE=3][COLOR=#000000]                                           Resize(.Rows.Count, .Columns.Count)[/COLOR][/SIZE][/FONT]
[FONT=Cambria][SIZE=3][COLOR=#000000]                       End With[/COLOR][/SIZE][/FONT]
[FONT=Cambria][SIZE=3][COLOR=#000000]                       destrange.Value = sourceRange.Value[/COLOR][/SIZE][/FONT]
[FONT=Cambria][SIZE=3][COLOR=#000000]                       rnum = rnum + SourceRcount[/COLOR][/SIZE][/FONT]
[FONT=Cambria][SIZE=3][COLOR=#000000]                   End If[/COLOR][/SIZE][/FONT]
[FONT=Cambria][SIZE=3][COLOR=#000000]                End If[/COLOR][/SIZE][/FONT]
[FONT=Cambria][SIZE=3][COLOR=#000000]               mybook.Close savechanges:=False[/COLOR][/SIZE][/FONT]
[FONT=Cambria][SIZE=3][COLOR=#000000]            End If[/COLOR][/SIZE][/FONT]

[FONT=Cambria][SIZE=3][COLOR=#000000]        Next FNum[/COLOR][/SIZE][/FONT]
[FONT=Cambria][SIZE=3][COLOR=#000000]       BaseWks.Columns.AutoFit[/COLOR][/SIZE][/FONT]
[FONT=Cambria][SIZE=3][COLOR=#000000]    End If[/COLOR][/SIZE][/FONT]

[FONT=Cambria][SIZE=3][COLOR=#000000]ExitTheSub:[/COLOR][/SIZE][/FONT]
[FONT=Cambria][SIZE=3][COLOR=#000000]    ' Restore theapplication properties.[/COLOR][/SIZE][/FONT]
[FONT=Cambria][SIZE=3][COLOR=#000000]    With Application[/COLOR][/SIZE][/FONT]
[FONT=Cambria][SIZE=3][COLOR=#000000]       .ScreenUpdating = True[/COLOR][/SIZE][/FONT]
[FONT=Cambria][SIZE=3][COLOR=#000000]        .EnableEvents= True[/COLOR][/SIZE][/FONT]
[FONT=Cambria][SIZE=3][COLOR=#000000]        .Calculation =CalcMode[/COLOR][/SIZE][/FONT]
[FONT=Cambria][SIZE=3][COLOR=#000000]    End With[/COLOR][/SIZE][/FONT]
[FONT=Cambria][SIZE=3][COLOR=#000000]    ChDirNetSaveDriveDir[/COLOR][/SIZE][/FONT]
[FONT=Cambria][SIZE=3][COLOR=#000000]End Sub[/COLOR][/SIZE][/FONT]
 
Last edited by a moderator:

Excel Facts

Which Excel functions can ignore hidden rows?
The SUBTOTAL and AGGREGATE functions ignore hidden rows. AGGREGATE can also exclude error cells and more.
You must log in or register to reply here.

Similar threads

M
  • Question Question
how to modify code to allow transpose copied data?
Replies
0
Views
427
mohammad90
M
H
  • Solved
Merging multiple workbooks into one from a folder
Replies
3
Views
717
Dan_W
D
Logit
  • Question Question
Search In Other Workbook - Copy/Paste Offset Data To First Workbook - Repeat Process
Replies
7
Views
262
Logit
Logit
N
  • Solved
Excel 2016 VBA - Pull data from multiple sheets to One with specificities
Replies
3
Views
250
mumps
mumps
B
  • Question Question
VBA to extract data from multiple folders and add to a master workbook plus identifying tags
Replies
2
Views
1K
John_w
J

Forum statistics

Threads
1,223,236
Messages
6,170,906
Members
452,366
Latest member
TePunaBloke

Share this page

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
Back
Top