I have a worksheet with many columns (82 in my case) and I am looking to create a csv-file for each column. I manage to do it with the below code, thanks to the help of many questions/answers on this site. Running the code gives some action on the windows taskbar I have not seen before (the creation and closing of the files) but I have the feeling there is a more efficient and faster way. Any suggestions?
' Create a separate csv file for each column.
Sub ColumnsToCSV()
Dim i As Byte
Dim cols As Byte ' column count
Dim name As String ' 01, 02, .., 99
cols = ActiveSheet.UsedRange.SpecialCells(xlCellTypeLastCell).Column ' count columns
For i = 1 To cols ' loop columns
name = Format(i, "00") ' 1 => 01, etc.
Sheets.Add(After:=Sheets(Sheets.Count)).name = name ' add sheet
Sheets("Data").Columns(i).Copy Destination:=Sheets(name).Columns(1) ' copy data
ThisWorkbook.Sheets(name).Copy ' create copy
ActiveWorkbook.SaveAs Filename:=name, FileFormat:=xlCSV ' save to csv
ActiveWorkbook.Close ' close csv
Application.DisplayAlerts = False ' disable alerts
ActiveSheet.Delete ' delete sheet
Application.DisplayAlerts = True ' enable alerts
Next i
End Sub
Try this out:
' Create a separate csv file for each column.
Sub ColumnsToCSV()
Dim name As String, pth As String, cols As Long, i As Long
Dim rng As Range, data, ws As Worksheet, r As Long, v
Set ws = ActiveSheet
cols = ws.UsedRange.SpecialCells(xlCellTypeLastCell).Column
pth = ThisWorkbook.Path & "\" 'or whereever you want to save....
For i = 1 To cols
data = AsArray(ws.Range(ws.Cells(1, i), ws.Cells(Rows.Count, i).End(xlUp)))
For r = 1 To UBound(data, 1)
v = data(r, 1)
If InStr(v, ",") > 0 Then data(r, 1) = """" & v & """" 'quote commas
Next r
'write the output (note Tanspose() has a limit of approx 63k items)
PutContent pth & Format(i, "00") & ".csv", _
Join(Application.Transpose(data), vbCrLf)
Next i
End Sub
'write text to a file
Sub PutContent(f As String, content As String)
CreateObject("scripting.filesystemobject"). _
opentextfile(f, 2, True).write content
End Sub
'return range value as array (handle case where range is a single cell)
Function AsArray(rng As Range)
Dim rv()
If rng.Cells.Count = 1 Then
ReDim rv(1 To 1, 1 To 1)
rv(1, 1) = rng.Value
AsArray = rv 'edit: this was missing...
Else
AsArray = rng.Value
End If
End Function
Related
I'd like to output text file from some sample excel files.
So that I created following samples.
after opening text file , each rows are printed.
But when I try to loop over columns , these values are appended in one columns
Are there any good way to achieve row and column based loop ?
This text file uses comma separator.
Thanks.
Sub Test_Open()
Dim strFilePath As String
Dim ws As Worksheet
strFilePath = "C:\Users\test\text.txt"
Workbooks.Open "C:\Users\test.xlsx"
Set ws = ActiveWorkbook.Worksheets("test")
Open strFilePath For Output As #1
Dim row As Integer
Dim column As Integer
row = 7
Do Until ws.Cells(row, 2).Value = ""
For column = 1 To 86
Print #1, ws.Cells(row, column)
Next
row = row + 1
Loop
Close #1
End Sub
You can add some variable to hold all your column information.
Change your code
For column = 1 To 86
Print #1, ws.Cells(row, column)
Next
To this code.
Dim cols As String
' Add all column separated by comma(,)
For column = 1 To 86
cols = cols & "," & ws.Cells(row, column)
Next
' Trim first comma(,)
cols = Mid(cols, 2)
' Write column to one line at last
Print #1, cols
You can save it with Workbook.SaveAs as *.csv with requered options
Sub Test_Open()
Dim strFilePath As String
strFilePath = "c:\test\text.txt"
With Workbooks.Open("c:\test\test.xlsx").Worksheets("test")
.SaveAs strFilePath, xlCSV
.Parent.Close False
End With
End Sub
Please, try the next code:
Sub Test_Open()
Dim strFilePath As String, wb As Workbook, ws As Worksheet
Dim i As Long, j As Long, txtArr, colArr, nrCol As Long, arrFin
strFilePath = "C:\Users\test\text.txt"
Set wb = Workbooks.Open("C:\Users\test.xlsx")
Set ws = wb.Worksheets("test")
txtArr = Split(CreateObject("Scripting.FileSystemObject").OpenTextFile(strFilePath, 1).ReadAll, vbCrLf)
nrCol = UBound(Split(txtArr(0), ","))
ReDim arrFin(1 To UBound(txtArr) - 6, 1 To nrCol)
For i = 6 To UBound(txtArr)
colArr = Split(txtArr(i), ",")
For j = 0 To nrCol
arrFin(i + 1, j + 1) = colArr(j)
Next j
Next
ws.Range("A1").Resize(UBound(arrFin), UBound(arrFin, 2)).value = arrFin
End Sub
The code is not tested. If you would share the file you use, I will test it and eventually optimize something, if the case...
If something unclear, do not hesitate to ask for clarifications. I can comment the lines which look more difficult to be understood.
Beginner in VBA so sorry if the code is bad.
What I wanted to achieve was to search a folder and its sub folders for the .dxf file of a part number listed in Column B, and return either a "Yes" or "No" depending on whether that .dxf file exist in that folder or its sub folders.
What I expected was that the code would begin with the first part number listed in B2, search the folder and sub folders for the .dxf file related, return a value, then move on to the next one, B3 then B4 and so on until the part numbers stop.
What it does is search a folder for all listed part numbers in Column B, returns all values, then searches a subfolder, returns all values (overriding the previous results) and so on until there are no more subfolders to search.
I feel like I'm close to getting the result I want but not sure where I've gone wrong.
Code is below:
Option Explicit
Dim FileSystem As Object
Dim HostFolder As String
Sub FindFile()
HostFolder = "C:\Users\Anyone\DXF\"
Set FileSystem = CreateObject("Scripting.FileSystemObject")
DoFolder FileSystem.GetFolder(HostFolder)
End Sub
Sub DoFolder(Folder)
Dim SubFolder
Dim Row As Integer
Dim Extension As String
Dim Continue As Boolean
For Each SubFolder In Folder.SubFolders
DoFolder SubFolder
Next
Dim File
For Each File In Folder.Files
Continue = True
Extension = ".DXF"
Row = 2
While Continue
If Len(Range("B" & CStr(Row)).Value) = 0 Then Exit Sub
If Len(Dir(Folder.Path & "\" & Range("B" & CStr(Row)).Value & "*" & Extension)) = 0 Then
Range("F" & CStr(Row)).Value = "No"
Else
Range("F" & CStr(Row)).Value = "Yes"
End If
Row = Row + 1
Wend
Next
End Sub
I would rethink the approach here. Maybe try a macro to manage the row loop and a function to manage the file lookup
First macro to loop through all file names in Column B and outputs if a file is found in Column C
Second macro to search a folder/subfolder path. If the file is found, the loop ends and returns TRUE. If a file is not found, the macro runs it's course and exists with FALSE
Note the function is just demonstrating the logic. You just need to take the logic you have to manage the folder loop and implement in this function
Sub File_Range()
Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("Sheet1")
Dim lr As Long, i As Long
lr = ws.Range("B" & ws.Rows.Count).End(xlUp).Row
For i = 2 To lr
If Not IsEmpty(ws.Range("B" & i)) Then
ws.Range("C" & i) = File_Exists(Range("B" & i))
End If
Next i
End Sub
Public Function File_Exists(Target As Range) As Boolean
'False until file is found
File_Exists = False
For Each SubFolder In Folder.SubFolders
If Len(Dir(Folder.Path & "\" & Target.Value & "*" & Extension)) Then
File_Exists = True
Exit Function
End If
Next SubFolder
End Function
Check Files for Existence
The Basics
Basically (inaccurately), the following writes all file paths of the required (DXF) files found in the supplied folder path to an array, replaces them with file names without file extension and checks the values (file names) in the source column against the array and finally writes the required results (Yes/No) to the destination column.
Adjust the values in the constants section.
Only run checkFiles, the rest is being called by it.
Additional Functionality
To better understand the flow, in the Immediate window CTRL+G, you can monitor what is happening, if you uncomment the Debug.Print sections. Note that Join will fail if error values, but you can always create a loop like it is done for mData which possibly (probably) contains error values.
It will allow different worksheets for source and destination data.
If will allow source and destination data starting in different rows.
The Code
Option Explicit
Sub checkFiles()
Const FolderPath As String = "C:\Users\Anyone\DXF"
Const FileExt As String = "DXF" ' Not case-sensitive i.e. 'DXF = dxf'
Const fFound As String = "Yes"
Const fNotFound As String = "No"
Const srcName As String = "Sheet1"
Const srcFirst As String = "B2"
Const dstName As String = "Sheet1"
Const dstFirst As String = "F2"
Dim wb As Workbook
Set wb = ThisWorkbook
Dim rng As Range ' (Source and Destination) Data Range
Dim Data As Variant ' (Source and Destination) Data Array
Dim fData() As String ' File Data Array
Dim mData As Variant ' Match Data Array
Dim n As Long ' File Data and (Match) Data Array Elements Counter
' Write values from Source Range to Data Array.
Set rng = defineColumnRange(defineRange(wb.Worksheets(srcName), srcFirst))
Data = getColumn(rng)
'Debug.Print "Source Data:" & vbLf & Join(Application.Transpose(Data), vbLf)
' Write file paths to File Data Array.
fData = getFilePaths(FolderPath, "*." & FileExt)
'Debug.Print "File Data - File Paths:" & vbLf & Join(fData, vbLf)
' Replace file paths with file names without file extension.
For n = LBound(fData) To UBound(fData)
fData(n) = FileFromPath(fData(n), True) ' 'True' means no extension.
Next n
'Debug.Print "File Data - File Names:" & vbLf & Join(fData, vbLf)
' Write 'matches' to Match Data Array.
mData = Application.Match(Data, fData, 0)
'Debug.Print "Match Data:"
'For n = 1 To UBound(mData)
' Debug.Print mData(n, 1)
'Next
' Overwrite values in Data Array with 'matching results'.
For n = 1 To UBound(Data) ' or 'UBound(mData)'
If IsNumeric(mData(n, 1)) Then
Data(n, 1) = fFound
Else
Data(n, 1) = fNotFound
End If
Next n
'Debug.Print "Destination Data:" & vbLf _
& Join(Application.Transpose(Data), vbLf)
' Write values from Data Array to Destination Range.
With defineRange(wb.Worksheets(dstName), dstFirst)
Dim RowOffset As Long: RowOffset = .Row - rng.Row
Dim ColumnOffset As Long: ColumnOffset = .Column - rng.Column
Set rng = .Worksheet.Range(rng.Offset(RowOffset, ColumnOffset).Address)
End With
rng.Value = Data
End Sub
Function defineRange( _
ws As Worksheet, _
ByVal RangeAddress As String) _
As Range
On Error Resume Next
Set defineRange = ws.Range(RangeAddress)
On Error GoTo 0
End Function
Function defineColumnRange( _
FirstCell As Range) _
As Range
If Not FirstCell Is Nothing Then
With FirstCell
Dim rng As Range
Set rng = .Resize(.Worksheet.Rows.Count - .Row + 1)
Set rng = rng.Find("*", , xlFormulas, , , xlPrevious)
If Not rng Is Nothing Then
Set defineColumnRange = .Resize(rng.Row - .Row + 1)
End If
End With
End If
End Function
Function getColumn( _
rng As Range) _
As Variant
If Not rng Is Nothing Then
If InStr(rng.Address, ":") > 0 Then
getColumn = rng.Value
Else
Dim Data As Variant
ReDim Data(1 To 1, 1 To 1)
Data(1, 1) = rng.Value
getColumn = Data
End If
End If
End Function
Function getFilePaths( _
ByVal FolderPath As String, _
Optional ByVal FilePattern As String = "") _
As Variant
Dim ExecString As String
ExecString = "cmd /c Dir """ & FolderPath & Application.PathSeparator _
& FilePattern & """ /b/s"
getFilePaths = Filter(Split(CreateObject("WScript.Shell") _
.Exec(ExecString).StdOut.ReadAll, vbCrLf), ".") ' 'vbCrLf' is a must.
End Function
Function FileFromPath( _
ByVal FilePath As String, _
Optional ByVal NoExtension As Boolean = False) _
As String
Dim FileName As String
FileName = Right(FilePath, _
Len(FilePath) - InStrRev(FilePath, "\"))
If NoExtension Then
FileName = Left(FileName, InStrRev(FileName, ".") - 1)
End If
FileFromPath = FileName
End Function
I am trying to copy data from multiple source files into a destination file.
So a folder has all the source files I receive.
I now have to collate the data from the files received into a single workbook.
Source file
Destination file/Collation file
I am trying to get some help in collating from each source file in the folder into the destination file.
Sub Transfer_data()
Dim wb As String
Dim i As Long
Dim j As Long
Dim lr As Long
Application.ScreenUpdating = False
i = 0
j = 0
wb = Dir(ThisWorkbook.Path & "\*")
Do Until wb = ""
If wb <> ThisWorkbook.Name Then
Workbooks.Open ThisWorkbook.Path & "\" & wb
With Workbooks(wb).Sheets("D. P & c data")
For i = 21 To 26
For j = 3 To 60 Step 10
.Range(Cells(i, 3), Cells(i, 12)).Copy ThisWorkbook.Sheets("P and c data").Cells(Rows.Count, j).End(xlUp).Offset(1)
Next j
Next i
End With
Application.CutCopyMode = False
Workbooks(wb).Close True
End If
wb = Dir
Loop
Application.ScreenUpdating = True
MsgBox " Copy Complete"
End Sub
I am unsure of what is going on in your code before and after the loop. I think the below loop is what you are looking for. Putting rows outside of columns is easier.
For i = 21 To 26
For j = 3 To 13
Dim lr As Long
lr = ThisWorkbook.Sheets("P and c data").Range("C" & Rows.Count).End(xlUp).Row + 1
Cells(i, j).Copy
Sheets("P and c data").Cells(lr, 3).PasteSpecial
Next j
Next i
Copy Range by Row to Single Row
Option Explicit
' Copies values from a specified range (srcAddr)
' in a specified worksheet (srcID) in all workbooks ("*.xls*") in the folder
' of ThisWorkbook (ThisWorkbook excluded), to a specified worksheet (tgtID)
' in ThisWorkbook. The values of the range are copied into a single row
' starting from a specified column (tgtCol), each row of the range next
' to the previous.
Sub transferData()
Const srcID As Variant = "D. P & c data" ' Name or Index e.g. "Sheet1" or 1
Const srcAddr As String = "C21:L26"
Const tgtID As Variant = "P and c data" ' Name or Index e.g. "Sheet1" or 1
Const tgtCol As Variant = 3 ' Number or String e.g. 1 or "A"
Const Pattern As String = "*.xls*"
Dim wbPath As String: wbPath = ThisWorkbook.Path & Application.PathSeparator
Dim tgt As Worksheet: Set tgt = ThisWorkbook.Worksheets(tgtID)
Application.ScreenUpdating = False
Dim wb As Workbook, src As Worksheet, tgtCell As Range ' Objects
Dim Source As Variant, Target As Variant ' Arrays
Dim i As Long, j As Long, l As Long, Count As Long ' Counters (Longs)
Dim wbname As String: wbname = Dir(wbPath & Pattern)
Do Until wbname = ""
If wbname <> ThisWorkbook.Name Then
GoSub readSource
GoSub writeSource
GoSub writeTarget
End If
WorksheetNotFound:
wbname = Dir
Loop
Application.ScreenUpdating = True
MsgBox "Copied data from " & Count & " workbook(s) containing " _
& "a worksheet ID-ed with '" & srcID & "'.", _
vbInformation, "Data Transfer"
Exit Sub
readSource:
' Write values from Source Range to Source Array.
On Error Resume Next
Set src = Workbooks.Open(wbPath & wbname).Worksheets(srcID)
If Err.Number <> 0 Then GoTo closeSourceError
On Error GoTo 0
Source = src.Range(srcAddr).Value
' Uncomment the following line to write the names of the worksheets
' and the workbooks (that were read from) to the Immediate window (CTRL+G).
Debug.Print src.Name, src.Parent.Name
src.Parent.Close False ' Just reading, no need to save.
Return
writeSource:
' Write values from Source Array to Target Array.
ReDim Target(1 To 1, 1 To UBound(Source) * UBound(Source, 2))
l = 0
For i = 1 To UBound(Source)
For j = 1 To UBound(Source, 2)
l = l + 1
Target(1, l) = Source(i, j)
Next j
Next i
Return
writeTarget:
' Write values from Target Array to Target Range.
Set tgtCell = tgt.Cells(tgt.Rows.Count, tgtCol).End(xlUp).Offset(1)
tgtCell.Resize(, UBound(Target, 2)).Value = Target
Count = Count + 1
Return
closeSourceError:
src.Parent.Close False ' Just reading, no need to save.
On Error GoTo 0
GoTo WorksheetNotFound
End Sub
I have a script that processes a master file and creates a report per manager. In column A, all rows under mgr 1 are stored and printed to a template, and then it loops through all managers until the data ends.
Option Explicit
Sub Main()
Dim Wb As Workbook
Dim Data, Last
Dim i As Long, j As Long, k As Long, a As Long
Dim Dest As Range
'Refer to the template
Set Wb = Workbooks("SpecializedSkillsTemplate.xlsx")
'Refer to the destination cell
Set Dest = Wb.Sheets("Manager Summary").Range("B1")
'Read in all data
With ThisWorkbook.Sheets("Sheet7")
Data = .Range("Z2", .Range("A" & Rows.Count).End(xlUp))
End With
Wb.Activate
'Process the data
For i = 1 To UBound(Data)
'Manager changes?
If Data(i, 1) <> Last Then
'Skip the first
If i > 1 Then
'Scroll into the view
Dest.Select
'Save a copy
Wb.SaveCopyAs ThisWorkbook.Path & Application.PathSeparator & _
ValidFileName(Last & "_Assessment.xlsx")
End If
'Clear the employees
Dest.Resize(, Columns.Count - Dest.Column).EntireColumn.ClearContents
'Remember this manager
Last = Data(i, 1)
'Start the next round
j = 0
End If
'Write the employee data into the template
a = 0
For k = 2 To UBound(Data, 2)
Dest.Offset(a, j) = Data(i, k)
a = a + 1
Next
'Next column
j = j + 1
Next
End Sub
It takes the data from sheet 7 in the master file, but is it possible to have another For/Next loop that does this for another sheet? Say I have sheet 8 and I want it to do the same thing and take that employee data and transpose offset it by a column, so I can compare the two sets. Is this possible?
I was thinking of adding something like:
Dim Data2
With ThisWorkbook.Sheets("Sheet8")
Data2 = .Range("Z2, . Range("A" & Rows.Count).End(xlUp))
End With
and then another For/Next Loop:
For x = 1 to UBound(Data2)
If Data2(I,1) <> Last
Next
etc. Can anyone let me know if this is feasible?
Variantly Integrating For Next Loop
The Tasks
I've added 6 lines and modified one (marked with '*** in the code.
Added string constant that will hold sheet names.
Added variant where the sheet names will be put into and read from.
Added counter for looping through sheet names in variant.
Using the split function pasted data from string into variant (array).
Started For Next Loop.
Modified ThisWorkbook.Sheets().
Closed For Next Loop.
The Code
Option Explicit
Sub Main()
Const cStrSheet As String = "Sheet7,Sheet8,Sheet9" '***
Dim vntSheet As Variant ' ***
Dim iSheet As Integer ' ***
Dim Wb As Workbook
Dim Data, Last
Dim i As Long, j As Long, k As Long, a As Long
Dim Dest As Range
'Refer to the template
Set Wb = Workbooks("SpecializedSkillsTemplate.xlsx")
'Refer to the destination cell
Set Dest = Wb.Sheets("Manager Summary").Range("B1")
vntSheet = Split(cStrSheet, ",") '***
For iSheet = 0 To UBound(vntSheet) '***
'Read in all data
With ThisWorkbook.Sheets(vntSheet(iSheet)) '***
Data = .Range("Z2", .Range("A" & Rows.Count).End(xlUp))
End With
Wb.Activate
'Process the data
For i = 1 To UBound(Data)
'Manager changes?
If Data(i, 1) <> Last Then
'Skip the first
If i > 1 Then
'Scroll into the view
Dest.Select
'Save a copy
Wb.SaveCopyAs ThisWorkbook.Path & Application.PathSeparator & _
ValidFileName(Last & "_Assessment.xlsx")
End If
'Clear the employees
Dest.Resize(, Columns.Count - Dest.Column).EntireColumn.ClearContents
'Remember this manager
Last = Data(i, 1)
'Start the next round
j = 0
End If
'Write the employee data into the template
a = 0
For k = 2 To UBound(Data, 2)
Dest.Offset(a, j) = Data(i, k)
a = a + 1
Next
'Next column
j = j + 1
Next
Next ' iSheet '***
End Sub
I have many, over two dozen (and counting), data sets with 15000 rows and 36 columns each, that I would like to combine. These data sets are have the same columns and more or less the same rows. They are monthly snapshots of the same data, with some data leaving and some entering (hence the marginally different number of rows.
I would like the user to select some of them and and combine them. The name of the file contains that date and my code extracts the date and adds it in a new column at the end. Right now, my code works. I collect all the data in a three dimensional array and then paste it in a new workbook. The problem is that since each book has different numbers or rows, I am creating a data array with more rows than needed. So my data has a lot of empy rows right now. I guess I can delete the empty rows in the end. I am new to excel VBA and new to doing data work so I was wondering if there was a smarter, more efficient way of construction my panel.
Dim DataArray As Variant
Sub test()
Dim filespec As Variant, i As Integer
ReDim DataArray(0 To 20000, 0 To 36, 0 To 0)
' Here the user gets to select the files
On Error GoTo EndNow
filespec = Application.GetOpenFilename(FileFilter:="microsoft excel files (*.xls), *.xls", Title:="Get File", MultiSelect:=True)
For i = 1 To UBound(filespec)
ReDim Preserve DataArray(0 To 20000, 0 To 36, 0 To i)
Set wbSource = Workbooks.Open(filespec(i))
Set ws1 = wbSource.Worksheets("Sheet1")
With ws1
'now I store the values in my array
FinalColumn = .Cells(1, .Columns.Count).End(xlToLeft).Column
FinalRow = .Range("B" & .Rows.Count).End(xlUp).Row
For j = 1 To FinalRow
For k = 1 To FinalColumn
DataArray(j, k, i) = .Cells(j, k).Value
Next k
' Now I extract the date data from the file name and store it in the last column of my array.
DataArray(j, FinalColumn + 1, i) = piece(piece(GetFileName(CStr(filespec(i))), "_", 3), ".", 1)
Next j
End With
ActiveWorkbook.Close
Next i
Set wb2 = Application.Workbooks.Add
Set ws2 = wb2.Worksheets("Sheet1")
With ws2
For i = 1 To UBound(DataArray, 3)
FinalRow2 = 20000
FinalColumn2 = 36
For k = 1 To FinalColumn2
' I did this If loop so as to not copy headers every time.
If i = 1 Then
For j = 1 To FinalRow2
.Cells(j, k).Value = DataArray(j, k, i)
Next j
Else
For j = 2 To FinalRow2
.Cells(FinalRow2 * (i - 1) + j, k).Value = DataArray(j, k, i)
Next j
End If
Next k
Next i
wb2.Sheets(1).Name = "FolderDetails Panel Data"
wb2.SaveAs ThisWorkbook.Path & "Folder_Details_Panel_Data" & "_" & Format(Date, "yyyy_mm_dd"), _
FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
End With
EndNow:
End Sub
' MsgBox GetFileName(filespec(0))
Function GetFileName(filespec As String)
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
GetFileName = fso.GetFileName(filespec)
End Function
Function piece(Searchstring As String, Separator As String, IndexNum As Integer) As String
Dim t
t = Split(Searchstring, Separator)
If UBound(t) > 0 Then piece = t(IndexNum - 1)
End Function
To answer your direct question, I would copy the data from each workbook into the merged workbook as each is processed. I see no advantage in collecting all the data into a 3D array.
There are also many other issues with your code. What follows is a refactor of your code, with changes highlighted.
Option Explicit ' <-- Force declaration of all variables (must be first line in module)
Sub Demo()
Dim filespec As Variant
Dim i As Long ' --> Long is prefered over Integer
Dim DataArray As Variant ' <-- no need to be Module scoped
' --> Declare all your variables
Dim j As Long, k As Long
Dim wbSource As Workbook
Dim ws As Worksheet
Dim wbMerged As Workbook
Dim wsMerged As Worksheet
Dim DataHeader As Variant
Dim FinalRow As Long, FinalColumn As Long
Dim sDate As String
Dim rng As Range
' Here the user gets to select the files
On Error GoTo EndNow
filespec = Application.GetOpenFilename(FileFilter:="microsoft excel files (*.xls), *.xls", Title:="Get File", MultiSelect:=True)
If Not IsArray(filespec) Then
' <-- User canceled
Exit Sub
End If
' Speed up processing <--
' -- Comment these out for debugging purposes
'Application.ScreenUpdating = False
'Application.Calculation = xlCalculationManual
' Create Merged Workbook
Set wbMerged = Application.Workbooks.Add
Set wsMerged = wbMerged.Sheets(1)
wsMerged.Name = "FolderDetails Panel Data"
For i = 1 To UBound(filespec)
Set wbSource = Workbooks.Open(filespec(i))
Set ws = wbSource.Worksheets("Sheet1")
With ws
FinalColumn = .Cells(1, .Columns.Count).End(xlToLeft).Column
FinalRow = .Cells(.Rows.Count, 2).End(xlUp).Row
If i = 1 Then
' Get header from first workbook only
DataHeader = Range(.Cells(1, 1), .Cells(1, FinalColumn)).Value ' <-- Get data header
ReDim Preserve DataHeader(1 To 1, 1 To UBound(DataHeader, 2) + 1) ' <-- Range.Value arrays are 1 based
k = UBound(DataHeader, 2)
DataHeader(1, k) = "Date" ' <-- Header
End If
' Get all data in one go, excluding header
DataArray = Range(.Cells(2, 1), .Cells(FinalRow, FinalColumn)).Value ' <-- Array size matches data size
End With
wbSource.Close False
' Add Date to data
sDate = GetDateFromFileName(filespec(i)) '<-- do it once
' resize data array
ReDim Preserve DataArray(1 To UBound(DataArray, 1), 1 To UBound(DataArray, 2) + 1) ' <-- Range.Value arrays are 1 based
' Add date data
For j = 1 To UBound(DataArray, 1)
DataArray(j, k) = sDate
Next j
' Complete processing of each workbook as its opened
With wsMerged
' Add header row from first workbook
If i = 1 Then
Range(.Cells(1, 1), .Cells(1, UBound(DataArray, 2))) = DataHeader
End If
' <-- Add data to end of sheet
' Size the destination range to match the data
Set rng = .Cells(.Rows.Count, 2).End(xlUp).Offset(1, -1)
Set rng = rng.Resize(UBound(DataArray, 1), UBound(DataArray, 2))
rng = DataArray
End With
Next i
' <-- append \ to path
wbMerged.SaveAs ThisWorkbook.Path & "\" & "Folder_Details_Panel_Data" & "_" & Format(Date, "yyyy_mm_dd"), _
FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
CleanUp:
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Exit Sub
EndNow:
MsgBox "Oh dear"
GoTo CleanUp
End Sub
' Simplified
' <-- Not entirely sure if this will match your file name pattern.
' Please check
' Assumed file name
' Some\Path\Some_Words_YYYMMDD.xls
Function GetDateFromFileName(Nm As Variant) As String
Dim str As String
str = Mid$(Nm, InStrRev(Nm, "\") + 1)
str = Left$(str, InStrRev(str, ".") - 1)
str = Mid$(str, InStrRev(str, "_") + 1)
GetDateFromFileName = str
End Function