Extracting multiple data from multiple files

[jose84]

Hi, im very new into macros, and I need help with this,

I have a lot of files which I need to take out data from, and need to put it into one single sheet (summary). Also, with the attached code puts the data in rows, I need to have them in columns.

Many thanks in advance,

I have this code:

Sub Extracting_Data()
Dim basebook As Workbook
Dim mybook As Workbook
Dim rnum As Long
Dim FNames As String
Dim MyPath As String
Dim SaveDriveDir As String
Dim Cnum As Integer
Dim cell As Range
SaveDriveDir = CurDir
MyPath = "D:\Documents and Settings\documents"
'file path
ChDrive MyPath
ChDir MyPath
FNames = Dir("*.xls")
If Len(FNames) = 0 Then
MsgBox "No files in the Directory"
ChDrive SaveDriveDir
ChDir SaveDriveDir
Exit Sub
End If
Application.ScreenUpdating = False
Set basebook = ThisWorkbook
'clear all cells on the first sheet
basebook.Worksheets(1).Cells.Clear
rnum = 1
Do While FNames <> ""
Set mybook = Workbooks.Open(FNames)
' This will add the workbook name in column A if you want
basebook.Worksheets(1).Cells(rnum, "A").Value = mybook.Name
' Copy the cell values from each cell in one row starting in column B
Cnum = 2
For Each cell In mybook.Worksheets(1).Range("C7:K30")
basebook.Worksheets(1).Cells(rnum, Cnum).Value = cell.Value
Cnum = Cnum + 1
Next cell
mybook.Close False
rnum = rnum + 1
FNames = Dir()
Loop
ChDrive SaveDriveDir
ChDir SaveDriveDir
Application.ScreenUpdating = True
End Sub

 

[Trevor G]

When you say you want to copy to columns, do you mean select a range of cells in a column from each workbook then add them into a master pasting the selected cells into the next column?

 

[RichardMGreen]

Once the workbook is open, why not just do a copy/paste to the relevant place in the workbook (transposing if necessary)?
You can then find the next available slot to paste the next set of data.

 

[jose84]

Ok, what I need the macro to do is:

1-) Open several files from a specific folder
2-) search data in each file (I need in specific 3 columns
3-) paste the data in a new worksheet,

Many thanks in advance.

 

[RichardMGreen]

Some question then:-
Which columns are you copying from in each workbook (and are they alsways the same)?
Which columns are you pasting into?
Where are the headers (if any)?
Do you always want the data pasted directly underneath the previous set?

 

[jose84]

Answer 1: Now that I see I need an specific range (always the same)

1 Range --> C7:C20
2 Range --> D7:D20
3 Range --> K7:K20

Answer 2: I wanna paste into a new worksheet, column B,C,D

Anwer 3: I dont need the headers but maybe the names of the files,

Answer 4: Would be possible to leave an row in between after a file is close and searh for the next one,

many many thanks

 

[RichardMGreen]

OK, this code hasn't been tested, but should be close:-

Sub Extracting_Data()
    Dim basebook As Workbook, mybook As Workbook, rnum As Long, FNames As String
    Dim MyPath As String, SaveDriveDir As String, Cnum As Integer, cell As Range
    SaveDriveDir = CurDir
    MyPath = "D:\Documents and Settings\documents"
'   file path
    FNames = Dir(mypath & "*.xls")
    If Len(FNames) = 0 Then
        MsgBox "No files in the Directory"
        ChDir SaveDriveDir
        Exit Sub
    End If
    Application.ScreenUpdating = False
    Set basebook = ThisWorkbook
'   clear all cells on the first sheet
    basebook.Worksheets(1).Cells.Clear
    offsetvalue=1
    Do While FNames <> ""
        Set mybook = Workbooks.Open(FNames)
'        This will add the workbook name in column A if you want
        basebook.Worksheets(1).Range("B65535").end(xlup).offset(offsetvalue).Value = mybook.Name
'       Copy the cell values from each cell in one row starting in column B
        mybook.activesheet.Range("C7:C20").copy
        basebook.worksheets(1).range("B65535").end(xlup).offset(offsetvalue).pastespecial (xlpastespecialvalues)
        mybook.activesheet.Range("D7:D20").copy
        basebook.worksheets(1).range("C65535").end(xlup).offset(offsetvalue).pastespecial (xlpastespecialvalues)
        mybook.activesheet.Range("K7:K20").copy
        basebook.worksheets(1).range("D65535").end(xlup).offset(offsetvalue).pastespecial (xlpastespecialvalues)
        offsetvalue=2
        application.cutcopymode=false
        mybook.Close False
        FNames = Dir()
    Loop
    ChDir SaveDriveDir
    Application.ScreenUpdating = True
End Sub

This should paste the first set of data in row 2 of basebook and then leave a gap of 1 row between each dataset.

 

[jose84]

Thanks for the code, it tells me File no file in the directory

 

[RichardMGreen]

Change this line:-
MyPath = "D:\Documents and Settings\documents"

to this:-
MyPath = "D:\Documents and Settings\documents\"

 

[jose84]

now i got a debug message:

Line 19, col 1

Set mybook = Workbooks.Open(FNames)