PDA

View Full Version : VBA Excel Transpose all files in a folder



HatSlayer
07-18-2011, 12:49 PM
Hi!

Im a VBA noob, Im trying to work out how to make a vba script transpose all csv's in a directory. I have got the code to transpose a single csv (below) but i dont know what to do to make the code loop through to the rest of the folder.

Any help would be amazing!


Sub transpose()
Dim wb As Workbook
Dim vData As Variant

Set wb = Workbooks.Open("C:\test\1.csv")

With wb.Sheets(1)
vData = .UsedRange.Value
vData = Application.Transpose(vData)
.UsedRange.Delete
.Cells(1, 1).Resize(UBound(vData, 1), _
UBound(vData, 2)).Value = vData
End With

wb.SaveAs "C:\test\1.csv", xlCSV

wb.Close False
Set wb = Nothing
End Sub

CatDaddy
07-18-2011, 01:14 PM
http://www.exceltip.com/st/List_files_in_a_folder_with_Microsoft_Scripting_Runtime_using_VBA_in_Micros oft_Excel/446.html

HatSlayer
07-18-2011, 01:58 PM
Thanks CatDaddy,

Im having a little difficulty understanding how to link the folder script to the transpose script. The link looks a little confusing.

CatDaddy
07-18-2011, 04:36 PM
Sub openAllfilesInALocation()
Dim i As Long
Dim fName As String
With Application.FileSearch
.NewSearch
.LookIn = "C:\TEST\"
.fileName = "*.csv"
.SearchSubFolders = True
.Execute

For i = 1 To .FoundFiles.Count
fName = .FoundFiles(i).Name
transpose fName, i
Next i

End With
End Sub

Sub transpose(fName As String, i As Long)
Dim wb As Workbook
Dim vData As Variant

Set wb = Workbooks.Open(fName)

With wb.Sheets(1)
vData = .UsedRange.Value
vData = Application.transpose(vData)
.UsedRange.Delete
.Cells(1, 1).Resize(UBound(vData, 1), _
UBound(vData, 2)).Value = vData
End With

wb.SaveAs "C:\TEST\Transpose" & i & ".csv", xlCSV

wb.Close False
Set wb = Nothing
End Sub


This doesnt quite work because im calling the filesearch function incorrectly but it is basically what your looking for i think

GTO
07-18-2011, 11:55 PM
Greetings HatSlayer,

I see you just joined. Welcome to VBAX!

Say, just in case you have 2007 or after and wanted to use FSO...not well tested or thought thru, but something like:
Option Explicit

Sub exa()
Dim FSO As Object
Dim fsoFile As Object
Dim CSV As Workbook
Dim strFolderName As String

'//Change folder to suit or place ThisWorkbook in same folder that csv's reside in. //
strFolderName = ThisWorkbook.Path & "\"

'// Set a reference to FSO //
Set FSO = CreateObject("Scripting.FileSystemObject")

With FSO
If Not .FolderExists(strFolderName) Then
MsgBox "Bad path...", 0, vbNullString
Exit Sub
End If

For Each fsoFile In .GetFolder(strFolderName).Files
If fsoFile.Type = "Microsoft Office Excel Comma Separated Values File" Then
Set CSV = Workbooks.Open(fsoFile.Path, , , 2)
Call TransposeSheet(csvfile:=CSV, HeaderRowCount:=0)
End If
Next
End With
End Sub

Function TransposeSheet(csvfile As Workbook, Optional HeaderRowCount As Long = 1)
Dim rngLastCol As Range
Dim rngLastRow As Range
Dim rngData As Range
Dim lLCol As Long
Dim lLRow As Long
Dim aryVals() As Variant

With csvfile.Worksheets(1)
'// Find a cell in the last column and row used //
Set rngLastCol = RangeFound(SearchRange:=Range(.Cells(HeaderRowCount + 1, "A"), _
.Cells(.Rows.Count, .Columns.Count)), _
SearchRowCol:=xlByColumns)

Set rngLastRow = RangeFound(SearchRange:=Range(.Cells(HeaderRowCount + 1, "A"), _
.Cells(.Rows.Count, .Columns.Count)))
'// Just in case an empty sheet //
If rngLastCol Is Nothing Then
lLCol = 1
Else
lLCol = rngLastCol.Column
End If

If rngLastRow Is Nothing Then
lLRow = HeaderRowCount + 1
Else
lLRow = rngLastRow.Row
End If

aryVals = Application.Transpose(Range(.Cells(HeaderRowCount + 1, "A"), _
.Cells(lLRow, lLCol)).Value)

Range(.Cells(HeaderRowCount + 1, "A"), .Cells(lLRow, lLCol)).Clear

Range(.Cells(HeaderRowCount + 1, "A"), _
.Cells(UBound(aryVals, 1) + HeaderRowCount, UBound(aryVals, 2))).Value = aryVals

Application.DisplayAlerts = False
.Parent.Save
.Parent.Close False
Application.DisplayAlerts = True
End With
End Function

Function RangeFound(SearchRange As Range, _
Optional FindWhat As String = "*", _
Optional StartingAfter As Range, _
Optional LookAtTextOrFormula As XlFindLookIn = xlValues, _
Optional LookAtWholeOrPart As XlLookAt = xlPart, _
Optional SearchRowCol As XlSearchOrder = xlByRows, _
Optional SearchUpDn As XlSearchDirection = xlPrevious, _
Optional bMatchCase As Boolean = False) As Range

If StartingAfter Is Nothing Then
Set StartingAfter = SearchRange(1)
End If

Set RangeFound = SearchRange.Find(What:=FindWhat, _
After:=StartingAfter, _
LookIn:=LookAtTextOrFormula, _
LookAt:=LookAtWholeOrPart, _
SearchOrder:=SearchRowCol, _
SearchDirection:=SearchUpDn, _
MatchCase:=bMatchCase)
End Function
Hope that helps,

Mark

HatSlayer
07-19-2011, 03:52 PM
Thanks both of you, GTO that worked perfectly, thanks a lot!

CatDaddy
07-19-2011, 04:16 PM
I tried to do the same thing as GTO at first, but i had trouble creating the scripting.filesystemobject