Transposing multiple files to one sheet

QuestionEdit

QUESTION: Thank you for your help with other items! I have multiple text files located in one folder. Data in each file is formatted like this: Date, 06/01/2010 Time,10:00:00 AM PartID,007 Test1,14 Test2,14.1

I want to import each file onto one worksheet that has columns and can put the data into a something that looks like this: A(Date) B(Time) C(PartID) D(Test1) E(Test2) 06/01/2010 10:00:00 AM 007 14 14.1 06/01/2010 10:05:00 AM 008 14.2 14.6 06/02/2010 02:00:00 PM 009 14.4 14.2

Any help with this would be greatly appreciated! Currently I open transpose and paste...but I have hundredes of these to do. Thank you!

ANSWER: Susan

put a list of all the files in sheet1 of the destination workbook (the workbook containing the code) with fully qualified path names such as: A1: C:\Myfolder\Myfile1.xls

Assume data is in the first sheet of each of the files in A1:B5 (row labels in column A, values in column B) A1: Date B1: 06/01/2010 A2: Time B2: 10:00:00 AM A3: PartID B3: 007 and so forth

Assume the transposed data will be pasted to sheet2 of the workbook containing the code

then

Sub ABC() Dim r As Range, cell As Range Dim rw As Long, sh As Worksheet Dim bk As Workbook, r1 As Range With ThisWorkbook.Worksheets("Sheet1")

  Set r = .Range("A1", .Cells(.Rows.Count, 1).End(xlUp))

End With rw = 2 Set sh = ThisWorkbook.Worksheets("Sheet2") For Each cell In r

 Set bk = Workbooks.Open(cell.Value)
 Set r1 = bk.Worksheets(1).Range("B1:B5")
 r1.Copy
 sh.Cells(rw, 1).PasteSpecial Transpose:=True
 rw = rw + 1
 bk.Close SaveChanges:=False

Next End Sub

Hope that works for you. If you have problems or don't understand the answer, then post a followup.

---------- FOLLOW-UP ----------

QUESTION: and thank you for the quick response. This is copying the values from B1:B5, but the file opened hasn't been seperated by the commas into two columns.

ANSWER: Susan,

Yes - that is what I expected. That was a detail I had to guess at and I explicitly stated that was what I was assuming by laying out what I through was in each cell. Here is an untested modification of the code that separates the data at the first column, placing the values only (right of the comma) in B1:B5. Since the source workbook is not saved, it should have no effect on the source workbook.

Sub ABC() Dim r As Range, cell As Range Dim rw As Long, sh As Worksheet Dim bk As Workbook, r1 As Range Dim iloc as long With ThisWorkbook.Worksheets("Sheet1")

 Set r = .Range("A1", .Cells(.Rows.Count, 1).End(xlUp))

End With rw = 2 Set sh = ThisWorkbook.Worksheets("Sheet2") For Each cell In r

Set bk = Workbooks.Open(cell.Value)
Set r1 = bk.Worksheets(1).Range("A1:A5")
bk.Worksheets(1).Range("B1:B5").ClearContents
for each cell1 in r1
  iloc = instr(1,cell1,",",vbTextcompare)
  if iloc = 0 then
    cell1.offset(0,1) = cell1
  else
    cell1.offset(0,1) = Mid(cell1,iloc + 1,len(cell1) - iloc)
  end if
Next
set r1 = bk.Worksheets(1).Range("B1:B5")
r1.Copy
sh.Cells(rw, 1).PasteSpecial Transpose:=True
rw = rw + 1
bk.Close SaveChanges:=False

Next End Sub

this assumes that cells B1:B5 are blank on each sheet.

Let me know if you have any more problems.

---------- FOLLOW-UP ----------

QUESTION: This works beautifully, but I do have one more question. Is there a script line that would eliminate the pop up window asking me if I want to save the copied data for future use on the clipboard?

AnswerEdit

Susan,

sorry for the delay - I am traveling.

Sub ABC() Dim r As Range, cell As Range Dim rw As Long, sh As Worksheet Dim bk As Workbook, r1 As Range Dim iloc as long With ThisWorkbook.Worksheets("Sheet1")

Set r = .Range("A1", .Cells(.Rows.Count, 1).End(xlUp))

End With rw = 2 Set sh = ThisWorkbook.Worksheets("Sheet2") For Each cell In r Set bk = Workbooks.Open(cell.Value) Set r1 = bk.Worksheets(1).Range("A1:A5") bk.Worksheets(1).Range("B1:B5").ClearContents for each cell1 in r1

 iloc = instr(1,cell1,",",vbTextcompare)
 if iloc = 0 then
   cell1.offset(0,1) = cell1
 else
   cell1.offset(0,1) = Mid(cell1,iloc + 1,len(cell1) - iloc)
 end if

Next set r1 = bk.Worksheets(1).Range("B1:B5") r1.Copy sh.Cells(rw, 1).PasteSpecial Transpose:=True ' this should clear the clipboard application.cutcopymode = false rw = rw + 1 bk.Close SaveChanges:=False Next End Sub