Transpose 100 sheets in a directory automaticaly

  • Thread starter Thread starter John L
  • Start date Start date
J

John L

Hello,

I will be receiving 100 or more xls per month which have rows as fields and
columns as cases/individuals/records, the opposite of standard db structure.

How would I go about writting a script that would open each of these and
transpose it without me doing them one by one? Their names will vary from
month to month.

Thanks in advance,

John
 
Hi John

Here is a solution which will open all of the xls files in a
designated directory. It assumes the sheet with the data on it is the
active sheet, it assumes the data commences in A1. It will copy the
current region, place a new worksheet in the book and paste the data
in the correct format (transposed). It will then save the workbook
and move onto the next book in the folder.

You will have to change the folder path. If you want this to be more
in line with your expectations can you please give more detailed
information. What is the sheet name of the workbook which you want
the data transposed from, what cell does the data commence in, are all
workbooks identical? Will the files be saved in a dedicated
directory. Where do you want the data transposed to - the sheet where
the data is on or a new sheet.

Anyways good luck with it.

Take care

Marcus

Option Explicit
Sub Open_Transpose()

Dim oWbk As Workbook
Dim sFil As String
Dim sPath As String
Dim twbk As Workbook
Dim strFullName As String

Application.DisplayAlerts = False
Application.ScreenUpdating = False

sPath = "P:\Finance\Integrated systems\Freight Business Plan
\Working Copies\Test" 'Chang to suit.
ChDir sPath
sFil = Dir("*.xls") 'All Excel files in folder can change this to
be more specific.

Do While sFil <> "" 'will start LOOP
strFullName = sPath & "\" & sFil
Workbooks.Open Filename:=(strFullName), UpdateLinks:=0
Range("A1").CurrentRegion.Copy
Worksheets.Add
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone,
SkipBlanks:=False, Transpose:=True
ActiveWorkbook.Close SaveChanges:=True

sFil = Dir
Loop ' End of LOOP

End Sub
 
Back
Top