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
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
Powered by vBulletin® Version 4.2.5 Copyright © 2024 vBulletin Solutions Inc. All rights reserved.