Hi all
The following is a multipart macro that is supposed to import various .txt files that are created through analyzing images in a software called Scion.
I am having trouble running the macro in Excel 2016 in compatibility mode. When I run the macro part named CL_Air_1, the file dialog does not list the *_CLa files even though they are in the folder I navigate to, and when I manually type in the .txt extension the dialog sees the files but when I click OK I get an error saying "subscript not found".
Any help is much appreciated. I am a biomedical person and have no clue about how to work with macros in excel.
Thanks
The following is a multipart macro that is supposed to import various .txt files that are created through analyzing images in a software called Scion.
I am having trouble running the macro in Excel 2016 in compatibility mode. When I run the macro part named CL_Air_1, the file dialog does not list the *_CLa files even though they are in the folder I navigate to, and when I manually type in the .txt extension the dialog sees the files but when I click OK I get an error saying "subscript not found".
Any help is much appreciated. I am a biomedical person and have no clue about how to work with macros in excel.
Thanks
Code:
Option ExplicitOption Base 1
'These constants are the only changes made for different magnification macro files
'BWH Leica Scope
Const cMicronsPerPixel = 1.908
Const cSqMicronsPerPixel = 3.642
Private Sub PageSetup()
With ActiveSheet.PageSetup
' .LeftHeader = ""
.CenterHeader = "&F"
.RightHeader = "Page &P"
' .LeftFooter = ""
' .CenterFooter = ""
' .RightFooter = ""
.LeftMargin = Application.InchesToPoints(0.7)
.RightMargin = Application.InchesToPoints(0.7)
.TopMargin = Application.InchesToPoints(1)
.BottomMargin = Application.InchesToPoints(1)
.HeaderMargin = Application.InchesToPoints(0.5)
.FooterMargin = Application.InchesToPoints(0.5)
' .PrintHeadings = False
' .PrintGridlines = False
' .PrintComments = xlPrintNoComments
' .PrintQuality = 600
' .CenterHorizontally = False
' .CenterVertically = False
.Orientation = xlLandscape
' .Draft = False
.PaperSize = xlPaperLetter
.FirstPageNumber = xlAutomatic
.Order = xlOverThenDown
' .BlackAndWhite = False
' .Zoom = 100
' .PrintErrors = xlPrintErrorsDisplayed
End With
End Sub
Private Sub CenterColTitles()
' Center column titles
Rows("2:2").Select
With Selection
.HorizontalAlignment = xlCenter
' .VerticalAlignment = xlBottom
' .WrapText = False
' .Orientation = 0
' .AddIndent = False
' .IndentLevel = 0
' .ShrinkToFit = False
' .ReadingOrder = xlContext
' .MergeCells = False
End With
End Sub
Sub CL_Air_1()
'For each selected chord length (*_CLa.TXT) file in the folder:
'Display data
'Display descriptive statistics in adjacent columns
'Leave blank column before next data column
On Error GoTo err_CL_Air_1
Dim NewBook As Workbook
Dim NewSheet As Worksheet
Dim fd As FileDialog 'File Picker dialog box.
Dim vSelectedItem As Variant 'contains selected file path- variant required for For Each...Next
Dim sFileName() As String 'holds sorted filepaths
Dim sFileSaveName As String 'workbook save name
Dim iStartPos, iEndPos As Integer
Dim i, iCol As Integer
Dim lEndRow As Long
Dim strColTitle As String
Dim aRange() As Range 'Array of ranges
Dim iRangeCnt As Integer 'Range array index
Dim lMeasCnt As Long 'Running total nr of measurements to prevent exceeding Excel row limit of 65536.
'Speed up macro execution (restored to True at exit)
Application.ScreenUpdating = False
'Load Analysis Toolpak if it is not currently loaded...
'The password to access function definintions is: Wildebeest
If fAddInLoaded("Analysis ToolPak - VBA") = -1 Then
' Error finding Analysis Toolpak...
MsgBox "Analysis ToolPak Not Found", vbExclamation
GoTo exit_CL_Air_1
End If
'File dialog box
Set fd = Application.FileDialog(msoFileDialogFilePicker)
fd.InitialFileName = "*_CLa.txt"
fd.Filters.Add "Chord length measurement files", "*.txt", 1
'Use the Show method to display the File Picker dialog box and return the user's action.
'The user pressed the action button.
If fd.Show = -1 Then
'Add new workbook named as selected folder
Set NewBook = Workbooks.Add
'Extract folder name from path
iEndPos = InStrRev(fd.InitialFileName, "\") - 1
iStartPos = InStrRev(fd.InitialFileName, "\", iEndPos - 1) + 1
NewBook.Title = Mid$(fd.InitialFileName, iStartPos, iEndPos - iStartPos + 1)
'Moved to end: NewBook.SaveAs fileName:=NewBook.Title & "_CL.xls"
'Add new worksheet
Set NewSheet = Worksheets.Add
NewSheet.Name = NewBook.Title
'Hide default sheets instead of deleting, to prevent warning
NewBook.Sheets("Sheet1").Visible = False
NewBook.Sheets("Sheet2").Visible = False
NewBook.Sheets("Sheet3").Visible = False
'Store FileDialogSelectedItems filename (text after last "\") in array then sort
i = 0
For Each vSelectedItem In fd.SelectedItems
i = i + 1
ReDim Preserve sFileName(i)
sFileName(i) = Mid$(vSelectedItem, InStrRev(vSelectedItem, "\") + 1)
Next
'If no files or valid filenames, exit
If i = 0 Then
MsgBox "No files to measure.", vbCritical, "Message"
GoTo exit_CL_Air_1
End If
'Sort
SelectionSortStrings sFileName
iCol = 1
ReDim aRange(1)
iRangeCnt = LBound(aRange)
lMeasCnt = 0
'For each selected file
For Each vSelectedItem In sFileName()
'Extract selected file name from path for column label
iEndPos = InStrRev(vSelectedItem, ".")
iStartPos = InStrRev(vSelectedItem, "\", iEndPos - 1) + 1
'Include parent folder in group name
strColTitle = NewBook.Title & "\" & Mid$(vSelectedItem, iStartPos, iEndPos - iStartPos)
'Import chord length data (pixels)
'Import resets column widths so do first
With ActiveSheet.QueryTables.Add(Connection:="TEXT;" & vSelectedItem, Destination:=ActiveSheet.Cells(3, (iCol)))
.Refresh
End With
'Column title and width
Cells(2, iCol).Value = "CL (px)"
Columns(iCol).ColumnWidth = Len("CL (px)")
'Group title
'Range(Cells(1, iCol), Cells(1, iCol + 2)).Select
Cells(1, iCol).Select
With Selection
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = True
.Value = strColTitle
.Font.Bold = True
End With
'Chord length scaled in microns
Cells(2, iCol + 1).Value = "CL (µm)"
Columns(iCol + 1).ColumnWidth = Len("CL (µm)")
'Create formula and copy to new range
Cells(3, iCol + 1).FormulaR1C1 = "=+RC[-1]*" & cMicronsPerPixel
Cells(3, iCol + 1).Select
Selection.Copy
Columns(iCol).End(xlDown).Select
lEndRow = ActiveCell.Row
Range(Cells(4, iCol + 1), Cells(lEndRow, iCol + 1)).Select
ActiveSheet.Paste
'Copy scaled data over raw data, converting formulas to values
' (will not work with cut- use copy)
Range(Cells(2, iCol + 1), Cells(lEndRow, iCol + 1)).Select
Selection.Copy
Cells(2, iCol).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
'Delete source range
Range(Cells(2, iCol + 1), Cells(lEndRow, iCol + 1)).Select
Selection.ClearContents
'Number format for scaled data
Range(Cells(3, iCol), Cells(lEndRow, iCol)).NumberFormat = "0.0"
'If the total number of measurements exceeds Excel limit prompt and end macro.
'Although the imported column will contain fewer rows than the Excel limit,
'the Excel limit would be reached at the cut/paste into the All column stage.
'Quicker to prompt here.
lMeasCnt = lMeasCnt + Range(Cells(3, iCol), Cells(lEndRow, iCol)).Count
If lMeasCnt > 65536 Then
MsgBox "The total number of measurements has exceeded the Excel limit of 65536.", vbCritical
GoTo exit_CL_Air_1
End If
'Descriptive statistics
'Descr function: input range, output range, grouped, labels, summary, ds_large, ds_small, confidence
'Grouped="C" for columns, "R" for rows
Application.Run "ATPVBAEN.XLA!Descr", _
Range(Cells(2, iCol), Cells(lEndRow, iCol)), _
Cells(2, iCol + 1), "C", True, True
Columns(iCol + 1).ColumnWidth = 16 'stats col width
'Set numberformat for stats (limit range to keep count a whole number)
Range(Cells(3, iCol + 2), Cells(15, iCol + 2)).NumberFormat = "0.0"
Columns(iCol + 3).ColumnWidth = 5 'Blank column width
'Store current range in array
ReDim Preserve aRange(UBound(aRange) + 1)
Set aRange(iRangeCnt) = Range(Cells(3, iCol), Cells(lEndRow, iCol))
iRangeCnt = iRangeCnt + 1
iCol = iCol + 4
Next vSelectedItem
'Truncate empty range element
ReDim Preserve aRange(iRangeCnt - 1)
'All column title and width
Cells(1, iCol).Value = "All"
Cells(1, iCol).Font.Bold = True
Cells(2, iCol).Value = "CL (µm)"
Columns(iCol).ColumnWidth = Len("CL (µm)")
'Paste each column into all column
For iRangeCnt = LBound(aRange) To UBound(aRange)
aRange(iRangeCnt).Select
'Selection.Copy
Selection.Cut
'Find last row of destination column
Columns(iCol).End(xlDown).Select
lEndRow = ActiveCell.Row
Cells(lEndRow + 1, iCol).Select
'Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
ActiveSheet.Paste
Next
'Find last row of destination column
Columns(iCol).End(xlDown).Select
lEndRow = ActiveCell.Row
'All column number format
Range(Cells(3, iCol), Cells(lEndRow, iCol)).NumberFormat = "0.0"
'Descriptive statistics
Application.Run "ATPVBAEN.XLA!Descr", _
Range(Cells(2, iCol), Cells(lEndRow, iCol)), _
Cells(2, iCol + 1), "C", True, True
Columns(iCol + 1).ColumnWidth = 16 'stats col width
'Set numberformat for stats (limit range to keep count a whole number)
Range(Cells(3, iCol + 2), Cells(15, iCol + 2)).NumberFormat = "0.0"
'The user pressed Cancel.
Else
End If
'Set the object variable to Nothing.
Set fd = Nothing
CenterColTitles
PageSetup
Cells(1, 1).Select 'Reset data sheet position
'Save workbook
'sFileSaveName = Application.GetSaveAsFilename(NewBook.Title & "_CL.xls", "Excel Files (*.xls), *.xls")
'If sFileSaveName <> "False" Then
On Error Resume Next 'ignore rte 1004 if No reply to overwrite
'NewBook.SaveAs sFileSaveName
NewBook.SaveAs fileName:=NewBook.Title & "_CLa.xls"
On Error GoTo err_CL_Air_1
'End If
exit_CL_Air_1:
Application.ScreenUpdating = True
Exit Sub
err_CL_Air_1:
MsgBox Err.Description
Resume exit_CL_Air_1
End Sub
Sub CL_Tissue_1()
'For each selected chord length (*_CLt.TXT) file in the folder:
'Display data
'Display descriptive statistics in adjacent columns
'Leave blank column before next data column
On Error GoTo err_CL_Tissue_1
Dim NewBook As Workbook
Dim NewSheet As Worksheet
Dim fd As FileDialog 'File Picker dialog box.
Dim vSelectedItem As Variant 'contains selected file path- variant required for For Each...Next
Dim sFileName() As String 'holds sorted filepaths
Dim sFileSaveName As String 'workbook save name
Dim iStartPos, iEndPos As Integer
Dim i, iCol As Integer
Dim lEndRow As Long
Dim strColTitle As String
Dim aRange() As Range 'Array of ranges
Dim iRangeCnt As Integer 'Range array index
Dim lMeasCnt As Long 'Running total nr of measurements to prevent exceeding Excel row limit of 65536.
'Speed up macro execution (restored to True at exit)
Application.ScreenUpdating = False
'Load Analysis Toolpak if it is not currently loaded...
'The password to access function definintions is: Wildebeest
If fAddInLoaded("Analysis ToolPak - VBA") = -1 Then
' Error finding Analysis Toolpak...
MsgBox "Analysis ToolPak Not Found", vbExclamation
GoTo exit_CL_Tissue_1
End If
'File dialog box
Set fd = Application.FileDialog(msoFileDialogFilePicker)
fd.InitialFileName = "*_CLt.txt"
fd.Filters.Add "Chord length measurement files", "*.txt", 1
'Use the Show method to display the File Picker dialog box and return the user's action.
'The user pressed the action button.
If fd.Show = -1 Then
'Add new workbook named as selected folder
Set NewBook = Workbooks.Add
'Extract folder name from path
iEndPos = InStrRev(fd.InitialFileName, "\") - 1
iStartPos = InStrRev(fd.InitialFileName, "\", iEndPos - 1) + 1
NewBook.Title = Mid$(fd.InitialFileName, iStartPos, iEndPos - iStartPos + 1)
'Moved to end: NewBook.SaveAs fileName:=NewBook.Title & "_CL.xls"
'Add new worksheet
Set NewSheet = Worksheets.Add
NewSheet.Name = NewBook.Title
'Hide default sheets instead of deleting, to prevent warning
NewBook.Sheets("Sheet1").Visible = False
NewBook.Sheets("Sheet2").Visible = False
NewBook.Sheets("Sheet3").Visible = False
'Store FileDialogSelectedItems filename (text after last "\") in array then sort
i = 0
For Each vSelectedItem In fd.SelectedItems
i = i + 1
ReDim Preserve sFileName(i)
sFileName(i) = Mid$(vSelectedItem, InStrRev(vSelectedItem, "\") + 1)
Next
'If no files or valid filenames, exit
If i = 0 Then
MsgBox "No files to measure.", vbCritical, "Message"
GoTo exit_CL_Tissue_1
End If
'Sort
SelectionSortStrings sFileName
iCol = 1
ReDim aRange(1)
iRangeCnt = LBound(aRange)
lMeasCnt = 0
'For each selected file
For Each vSelectedItem In sFileName()
'Extract selected file name from path for column label
iEndPos = InStrRev(vSelectedItem, ".")
iStartPos = InStrRev(vSelectedItem, "\", iEndPos - 1) + 1
'Include parent folder in group name
strColTitle = NewBook.Title & "\" & Mid$(vSelectedItem, iStartPos, iEndPos - iStartPos)
'Import chord length data (pixels)
'Import resets column widths so do first
With ActiveSheet.QueryTables.Add(Connection:="TEXT;" & vSelectedItem, Destination:=ActiveSheet.Cells(3, (iCol)))
.Refresh
End With
'Column title and width
Cells(2, iCol).Value = "CL (px)"
Columns(iCol).ColumnWidth = Len("CL (px)")
'Group title
'Range(Cells(1, iCol), Cells(1, iCol + 2)).Select
Cells(1, iCol).Select
With Selection
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = True
.Value = strColTitle
.Font.Bold = True
End With
'Chord length scaled in microns
Cells(2, iCol + 1).Value = "CL (µm)"
Columns(iCol + 1).ColumnWidth = Len("CL (µm)")
'Create formula and copy to new range
Cells(3, iCol + 1).FormulaR1C1 = "=+RC[-1]*" & cMicronsPerPixel
Cells(3, iCol + 1).Select
Selection.Copy
Columns(iCol).End(xlDown).Select
lEndRow = ActiveCell.Row
Range(Cells(4, iCol + 1), Cells(lEndRow, iCol + 1)).Select
ActiveSheet.Paste
'Copy scaled data over raw data, converting formulas to values
' (will not work with cut- use copy)
Range(Cells(2, iCol + 1), Cells(lEndRow, iCol + 1)).Select
Selection.Copy
Cells(2, iCol).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
'Delete source range
Range(Cells(2, iCol + 1), Cells(lEndRow, iCol + 1)).Select
Selection.ClearContents
'Number format for scaled data
Range(Cells(3, iCol), Cells(lEndRow, iCol)).NumberFormat = "0.0"
'If the total number of measurements exceeds Excel limit prompt and end macro.
'Although the imported column will contain fewer rows than the Excel limit,
'the Excel limit would be reached at the cut/paste into the All column stage.
'Quicker to prompt here.
lMeasCnt = lMeasCnt + Range(Cells(3, iCol), Cells(lEndRow, iCol)).Count
If lMeasCnt > 65536 Then
MsgBox "The total number of measurements has exceeded the Excel limit of 65536.", vbCritical
GoTo exit_CL_Tissue_1
End If
'Descriptive statistics
'Descr function: input range, output range, grouped, labels, summary, ds_large, ds_small, confidence
'Grouped="C" for columns, "R" for rows
Application.Run "ATPVBAEN.XLA!Descr", _
Range(Cells(2, iCol), Cells(lEndRow, iCol)), _
Cells(2, iCol + 1), "C", True, True
Columns(iCol + 1).ColumnWidth = 16 'stats col width
'Set numberformat for stats (limit range to keep count a whole number)
Range(Cells(3, iCol + 2), Cells(15, iCol + 2)).NumberFormat = "0.0"
Columns(iCol + 3).ColumnWidth = 5 'Blank column width
'Store current range in array
ReDim Preserve aRange(UBound(aRange) + 1)
Set aRange(iRangeCnt) = Range(Cells(3, iCol), Cells(lEndRow, iCol))
iRangeCnt = iRangeCnt + 1
iCol = iCol + 4
Next vSelectedItem
'Truncate empty range element
ReDim Preserve aRange(iRangeCnt - 1)
'All column title and width
Cells(1, iCol).Value = "All"
Cells(1, iCol).Font.Bold = True
Cells(2, iCol).Value = "CL (µm)"
Columns(iCol).ColumnWidth = Len("CL (µm)")
'Paste each column into all column
For iRangeCnt = LBound(aRange) To UBound(aRange)
aRange(iRangeCnt).Select
'Selection.Copy
Selection.Cut
'Find last row of destination column
Columns(iCol).End(xlDown).Select
lEndRow = ActiveCell.Row
Cells(lEndRow + 1, iCol).Select
'Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
ActiveSheet.Paste
Next
'Find last row of destination column
Columns(iCol).End(xlDown).Select
lEndRow = ActiveCell.Row
'All column number format
Range(Cells(3, iCol), Cells(lEndRow, iCol)).NumberFormat = "0.0"
'Descriptive statistics
Application.Run "ATPVBAEN.XLA!Descr", _
Range(Cells(2, iCol), Cells(lEndRow, iCol)), _
Cells(2, iCol + 1), "C", True, True
Columns(iCol + 1).ColumnWidth = 16 'stats col width
'Set numberformat for stats (limit range to keep count a whole number)
Range(Cells(3, iCol + 2), Cells(15, iCol + 2)).NumberFormat = "0.0"
'The user pressed Cancel.
Else
End If
'Set the object variable to Nothing.
Set fd = Nothing
CenterColTitles
PageSetup
Cells(1, 1).Select 'Reset data sheet position
'Save workbook
'sFileSaveName = Application.GetSaveAsFilename(NewBook.Title & "_CL.xls", "Excel Files (*.xls), *.xls")
'If sFileSaveName <> "False" Then
On Error Resume Next 'ignore rte 1004 if No reply to overwrite
'NewBook.SaveAs sFileSaveName
NewBook.SaveAs fileName:=NewBook.Title & "_CLt.xls"
On Error GoTo err_CL_Tissue_1
'End If
exit_CL_Tissue_1:
Application.ScreenUpdating = True
Exit Sub
err_CL_Tissue_1:
MsgBox Err.Description
Resume exit_CL_Tissue_1
End Sub
Sub AP_No_Edge_1()
'Prompt for folder name
'For each area/perimeter (*_Aalv.TXT) file in the selected folder:
'Display data
'Display descriptive statistics in adjacent columns
'Leave blank column before next data column
On Error GoTo err_AP_No_Edge_1
Dim NewBook As Workbook
Dim NewSheet As Worksheet
Dim fd As FileDialog 'File Picker dialog box.
Dim vSelectedItem As Variant 'contains selected file path- variant required for For Each...Next
Dim sFileName() As String 'holds sorted filepaths
Dim sAirFileName As String
Dim sFileSaveName As String 'workbook save name
Dim i, iCol, iStartPos, iEndPos As Integer
Dim lEndRow As Long
Dim strColTitle As String
Dim aRangeAalv() As Range 'Array of ranges for Aalv
Dim aRangeAsur() As Range 'Array of ranges for Asurf
Dim aRangeAair() As Range 'Array of ranges for Aair
Dim aRangeAtis() As Range 'Array of ranges for Atis
Dim iRangeCnt As Integer 'Range array index
Dim lMeasCnt As Long 'Running total nr of measurements to prevent exceeding Excel row limit of 65536.
'Speed up macro execution (restored to True at exit)
Application.ScreenUpdating = False
'Load Analysis Toolpak if it is not currently loaded...
'The password to access function definintions is: Wildebeest
If fAddInLoaded("Analysis ToolPak - VBA") = -1 Then
' Error finding Analysis Toolpak...
MsgBox "Analysis ToolPak Not Found", vbExclamation
GoTo exit_AP_No_Edge_1
End If
'Setup file dialog
Set fd = Application.FileDialog(msoFileDialogFilePicker)
fd.InitialFileName = "*_Aalv.txt"
fd.Filters.Add "Area/perimeter measurement files", "*.txt", 1
'Use the Show method to display the File Picker dialog box and return the user's action.
'The user pressed the action button.
If fd.Show = -1 Then
'Add new workbook named as selected folder
Set NewBook = Workbooks.Add
'Extract folder name from path
iEndPos = InStrRev(fd.InitialFileName, "\") - 1
iStartPos = InStrRev(fd.InitialFileName, "\", iEndPos - 1) + 1
NewBook.Title = Mid$(fd.InitialFileName, iStartPos, iEndPos - iStartPos + 1)
'Moved to end: NewBook.SaveAs fileName:=NewBook.Title & "_A.xls"
'Add new worksheet
Set NewSheet = Worksheets.Add
NewSheet.Name = NewBook.Title
'Hide default sheets instead of deleting, to prevent warning
NewBook.Sheets("Sheet1").Visible = False
NewBook.Sheets("Sheet2").Visible = False
NewBook.Sheets("Sheet3").Visible = False
'Store FileDialogSelectedItems filename (text after last "\") in array then sort
i = 0
For Each vSelectedItem In fd.SelectedItems
i = i + 1
ReDim Preserve sFileName(i)
sFileName(i) = Mid$(vSelectedItem, InStrRev(vSelectedItem, "\") + 1)
Next
'If no files or valid filenames, exit
If i = 0 Then
MsgBox "No files to measure.", vbCritical, "Message"
GoTo exit_AP_No_Edge_1
End If
'Sort
SelectionSortStrings sFileName
iCol = 1
ReDim aRangeAalv(1)
ReDim aRangeAsur(1)
ReDim aRangeAair(1)
ReDim aRangeAtis(1)
iRangeCnt = LBound(aRangeAalv)
lMeasCnt = 0
For Each vSelectedItem In sFileName()
'Skip empty array elements
If vSelectedItem <> "" Then
'Extract selected file name from path for column label
iEndPos = InStrRev(vSelectedItem, ".")
iStartPos = InStrRev(vSelectedItem, "\", iEndPos - 1) + 1
'Include parent folder in group name
strColTitle = NewBook.Title & "\" & Mid$(vSelectedItem, iStartPos, iEndPos - iStartPos)
'strColTitle = Mid$(vSelectedItem, iStartPos, iEndPos - iStartPos)
'Import corresponding Aair_roi
sAirFileName = Mid$(vSelectedItem, 1, InStrRev(vSelectedItem, "Aalv")) + "air_roi.txt"
With ActiveSheet.QueryTables.Add(Connection:="TEXT;" & sAirFileName, Destination:=ActiveSheet.Cells(1, (iCol)))
.Refresh
End With
'Find last row
Columns(iCol).End(xlDown).Select
lEndRow = ActiveCell.Row
'Aair scaled to microns in next column
Cells(1, iCol + 1).FormulaR1C1 = "=+RC[-1]*" & cSqMicronsPerPixel
Cells(1, iCol + 1).Select
Selection.Copy
Range(Cells(2, iCol + 1), Cells(lEndRow, iCol + 1)).Select
ActiveSheet.Paste
'Copy Aroi cell value (last value in column) into destination cell
Cells(3, iCol + 3) = Cells(lEndRow, iCol + 1).Value
'Sum Air and enter into its cell
Cells(6, iCol + 3) = WorksheetFunction.Sum(Range(Cells(1, iCol + 1), Cells(lEndRow - 1, iCol + 1)))
'Set column title, width and number format
Cells(2, iCol + 3).Value = "Aroi (µm²)"
Cells(5, iCol + 3).Value = "Aair (µm²)"
Columns(iCol + 3).ColumnWidth = Len("Aroi (µm²)")
Columns(iCol + 3).NumberFormat = "0.0"
'Delete raw and scaled Aair columns.
Range(Cells(1, iCol), Cells(lEndRow, iCol + 1)).Select
Selection.ClearContents
'Import area and perimeter data (pixels)
'Import resets column widths so do first
With ActiveSheet.QueryTables.Add(Connection:="TEXT;" & vSelectedItem, Destination:=ActiveSheet.Cells(3, (iCol)))
.Refresh
End With
'Column title and width
Cells(2, iCol).Value = "Aalv(px)"
Columns(iCol).ColumnWidth = Len("Aalv (px)")
'Asurf (pixels)
'Set column title
'(contiguous cells required to find last cell)
Cells(1, iCol + 1).Value = "."
Cells(2, iCol + 1).Value = "Asurf (px)"
'Find last row
Columns(iCol + 1).End(xlDown).Select
lEndRow = ActiveCell.Row
Cells(1, iCol + 1).Clear 'remove "."
'Move column over
Columns(iCol + 1).Select
Selection.Cut
ActiveSheet.Paste Columns(iCol + 6)
'Set column width and number format
'Columns(iCol + 6).ColumnWidth = Len("Asurf (px)")
'Range(Cells(3, iCol + 6), Cells(lEndRow - 1, iCol + 6)).NumberFormat = "0.0"
'Above commented because column will be overwritten
'Aalv scaled to microns
'lEndRow same as Asurf column
Cells(3, iCol + 1).FormulaR1C1 = "=+RC[-1]*" & cSqMicronsPerPixel
Cells(3, iCol + 1).Select
Selection.Copy
Range(Cells(4, iCol + 1), Cells(lEndRow, iCol + 1)).Select
ActiveSheet.Paste
'Overwrite raw data with scaled data, converting formulas to values
' (will not work with cut- use copy)
Range(Cells(2, iCol + 1), Cells(lEndRow, iCol + 1)).Select
Selection.Copy
Cells(2, iCol).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
'Delete source range
Range(Cells(2, iCol + 1), Cells(lEndRow, iCol + 1)).Select
Selection.ClearContents
'Set column title, width and number format
Cells(2, iCol).Value = "Aalv (µm²)"
Columns(iCol).ColumnWidth = Len("Aalv (µm²)")
Range(Cells(3, iCol), Cells(lEndRow, iCol)).NumberFormat = "0.0"
'If the total number of measurements exceeds Excel limit prompt and end macro.
'Although the imported column will contain fewer rows than the Excel limit,
'the Excel limit would be reached at the cut/paste into the All column stage.
'Quicker to prompt here.
lMeasCnt = lMeasCnt + Range(Cells(3, iCol), Cells(lEndRow, iCol)).Count
If lMeasCnt > 65536 Then
MsgBox "The total number of measurements has exceeded the Excel limit of 65536.", vbCritical
GoTo exit_AP_No_Edge_1
End If
'Aalv descriptive statistics (first row of range is column title)
Application.Run "ATPVBAEN.XLA!Descr", _
Range(Cells(2, iCol), Cells(lEndRow, iCol)), _
Cells(2, iCol + 1), "C", True, True
'Set column width
Columns(iCol + 1).ColumnWidth = 16
'Set number format except for count which remains an integer
Range(Cells(3, iCol + 2), Cells(15, iCol + 2)).NumberFormat = "0.0"
'Airspace percent (Aair/Aroi)
'Set column title, width and number format
Cells(2, iCol + 4).Value = "Aair (%)"
Columns(iCol + 4).ColumnWidth = Len("Aair (%)")
Cells(3, iCol + 4).NumberFormat = "0.0"
'Calculate value
'Cells(3, iCol + 4).FormulaR1C1 = "=SUM(C[-4])/(C[-1])*100"
'ActiveSheet.Calculate
Cells(3, iCol + 4) = (Cells(6, iCol + 3) / Cells(3, iCol + 3)) * 100
'Tissue area (Aroi - Aair)
'Set column title, width and number format
Cells(2, iCol + 5).Value = "Atis (µm²)"
Columns(iCol + 5).ColumnWidth = Len("Atis (µm²)")
Cells(3, iCol + 5).NumberFormat = "0.0"
'Calculate value
'Cells(3, iCol + 5).FormulaR1C1 = "=(C[-2])-SUM(C[-5])"
'ActiveSheet.Calculate
Cells(3, iCol + 5) = Cells(3, iCol + 3) - Cells(6, iCol + 3)
'Asurf scaled to microns (uses non-squared conversion factor because it is perimeter (length)
Cells(3, iCol + 7).FormulaR1C1 = "=+RC[-1]*" & cMicronsPerPixel
Cells(3, iCol + 7).Select
Selection.Copy
Range(Cells(4, iCol + 7), Cells(lEndRow, iCol + 7)).Select
ActiveSheet.Paste
'Overwrite raw data with scaled data, converting formulas to values
' (will not work with cut- use copy)
Range(Cells(2, iCol + 7), Cells(lEndRow, iCol + 7)).Select
Selection.Copy
Cells(2, iCol + 6).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
'Delete source range
Range(Cells(2, iCol + 7), Cells(lEndRow, iCol + 7)).Select
Selection.ClearContents
'Set column title, width and number format
Cells(2, iCol + 6).Value = "Asurf (µm)"
Columns(iCol + 6).ColumnWidth = Len("Asurf (µm)")
Range(Cells(3, iCol + 6), Cells(lEndRow, iCol + 6)).NumberFormat = "0.0"
'Asurf descriptive statistics (first row of range is column title)
Application.Run "ATPVBAEN.XLA!Descr", _
Range(Cells(2, iCol + 6), Cells(lEndRow, iCol + 6)), _
Cells(2, iCol + 7), "C", True, True
'Set column width
Columns(iCol + 7).ColumnWidth = 16
'Set number format for stats (limit range to keep Count a whole number)
Range(Cells(3, iCol + 8), Cells(15, iCol + 8)).NumberFormat = "0.0"
'Set blank column width
Columns(iCol + 9).ColumnWidth = 5
'Group title
'Done at end of loop because cells used for title need to have text
' added to make contiguous column for finding last cell. Once cells
' are merged to store title, cannot add text to B1 and could not find
' last cell in column.
'Range(Cells(1, iCol), Cells(1, iCol + 2)).Select
Cells(1, iCol).Select
With Selection
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = True
.Value = strColTitle
.Font.Bold = True
End With
'Store current range in array
ReDim Preserve aRangeAalv(UBound(aRangeAalv) + 1)
ReDim Preserve aRangeAsur(UBound(aRangeAsur) + 1)
ReDim Preserve aRangeAair(UBound(aRangeAair) + 1)
ReDim Preserve aRangeAtis(UBound(aRangeAtis) + 1)
Set aRangeAalv(iRangeCnt) = Range(Cells(3, iCol), Cells(lEndRow, iCol))
Set aRangeAsur(iRangeCnt) = Range(Cells(3, iCol + 6), Cells(lEndRow, iCol + 6))
Set aRangeAair(iRangeCnt) = Range(Cells(3, iCol + 4), Cells(3, iCol + 4))
Set aRangeAtis(iRangeCnt) = Range(Cells(3, iCol + 5), Cells(lEndRow, iCol + 5))
iRangeCnt = iRangeCnt + 1
iCol = iCol + 10
End If
Next vSelectedItem
'Truncate empty range elements
ReDim Preserve aRangeAalv(iRangeCnt - 1)
ReDim Preserve aRangeAsur(iRangeCnt - 1)
ReDim Preserve aRangeAair(iRangeCnt - 1)
ReDim Preserve aRangeAtis(iRangeCnt - 1)
'All Aalv column title and width
Cells(1, iCol).Value = "All Aalv"
Cells(1, iCol).Font.Bold = True
Cells(2, iCol).Value = "Aalv (µm²)"
Columns(iCol).ColumnWidth = Len("Aalv (µm²)")
'Move each column into all column
For iRangeCnt = LBound(aRangeAalv) To UBound(aRangeAalv)
aRangeAalv(iRangeCnt).Select
'Selection.Copy
Selection.Cut
'Find last row of destination column
Columns(iCol).End(xlDown).Select
lEndRow = ActiveCell.Row
Cells(lEndRow + 1, iCol).Select
'Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
ActiveSheet.Paste
Next
'Find last row of destination column
Columns(iCol).End(xlDown).Select
lEndRow = ActiveCell.Row
'All column number format
Range(Cells(3, iCol), Cells(lEndRow, iCol)).NumberFormat = "0.0"
'All Aalv descriptive statistics
Application.Run "ATPVBAEN.XLA!Descr", _
Range(Cells(2, iCol), Cells(lEndRow, iCol)), _
Cells(2, iCol + 1), "C", True, True
Columns(iCol + 1).ColumnWidth = 16 'stats col width
'Set numberformat for stats (limit range to keep count a whole number)
Range(Cells(3, iCol + 2), Cells(15, iCol + 2)).NumberFormat = "0.0"
iCol = iCol + 4
'All Asurf column title and width
Cells(1, iCol).Value = "All Asurf"
Cells(1, iCol).Font.Bold = True
Cells(2, iCol).Value = "Asurf (µm)"
Columns(iCol).ColumnWidth = Len("Asurf (µm)")
'Paste each column into all column
For iRangeCnt = LBound(aRangeAsur) To UBound(aRangeAsur)
aRangeAsur(iRangeCnt).Select
'Selection.Copy
Selection.Cut
'Find last row of destination column
Columns(iCol).End(xlDown).Select
lEndRow = ActiveCell.Row
Cells(lEndRow + 1, iCol).Select
'Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
ActiveSheet.Paste
Next
'Find last row of destination column
Columns(iCol).End(xlDown).Select
lEndRow = ActiveCell.Row
'All column number format
Range(Cells(3, iCol), Cells(lEndRow, iCol)).NumberFormat = "0.0"
'All Asurf descriptive statistics
Application.Run "ATPVBAEN.XLA!Descr", _
Range(Cells(2, iCol), Cells(lEndRow, iCol)), _
Cells(2, iCol + 1), "C", True, True
Columns(iCol + 1).ColumnWidth = 16 'stats col width
'Set numberformat for stats (limit range to keep count a whole number)
Range(Cells(3, iCol + 2), Cells(15, iCol + 2)).NumberFormat = "0.0"
iCol = iCol + 4
'All Aair% column title and width
Cells(1, iCol).Value = "All Aair"
Cells(1, iCol).Font.Bold = True
Cells(2, iCol).Value = "Aair (%)"
Columns(iCol).ColumnWidth = Len("Aair (%)")
'Paste each column into all column
For iRangeCnt = LBound(aRangeAair) To UBound(aRangeAair)
aRangeAair(iRangeCnt).Select
Selection.Copy
'Find last row of destination column
Columns(iCol).End(xlDown).Select
lEndRow = ActiveCell.Row
Cells(lEndRow + 1, iCol).Select
'Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
ActiveSheet.Paste
Next
'Find last row of destination column
Columns(iCol).End(xlDown).Select
lEndRow = ActiveCell.Row
'All column number format
Range(Cells(3, iCol), Cells(lEndRow, iCol)).NumberFormat = "0.0"
'All Aair descriptive statistics
Application.Run "ATPVBAEN.XLA!Descr", _
Range(Cells(2, iCol), Cells(lEndRow, iCol)), _
Cells(2, iCol + 1), "C", True, True
Columns(iCol + 1).ColumnWidth = 16 'stats col width
'Set numberformat for stats (limit range to keep count a whole number)
Range(Cells(3, iCol + 2), Cells(15, iCol + 2)).NumberFormat = "0.0"
iCol = iCol + 4
'All Atis% column title and width
'Values are calculate from preceding Aair column
Cells(1, iCol).Value = "All Atis"
Cells(1, iCol).Font.Bold = True
Cells(2, iCol).Value = "Atis (%)"
Columns(iCol).ColumnWidth = Len("Atis (%)")
'Atis % = 100-Aair%
Cells(3, iCol).FormulaR1C1 = "=100-(+RC[-4])"
Cells(3, iCol).Select
Selection.Copy
Range(Cells(3, iCol), Cells(lEndRow, iCol)).Select 'Endrow from Aair column
ActiveSheet.Paste
'Convert formulas to values
Range(Cells(3, iCol), Cells(lEndRow, iCol)).Select
Selection.Copy
Cells(3, iCol).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
'All column number format
Range(Cells(3, iCol), Cells(lEndRow, iCol)).NumberFormat = "0.0"
'All Aair descriptive statistics
Application.Run "ATPVBAEN.XLA!Descr", _
Range(Cells(2, iCol), Cells(lEndRow, iCol)), _
Cells(2, iCol + 1), "C", True, True
Columns(iCol + 1).ColumnWidth = 16 'stats col width
'Set numberformat for stats (limit range to keep count a whole number)
Range(Cells(3, iCol + 2), Cells(15, iCol + 2)).NumberFormat = "0.0"
iCol = iCol + 4
'All Atis column title and width
Cells(1, iCol).Value = "All Atis"
Cells(1, iCol).Font.Bold = True
Cells(2, iCol).Value = "Atis (µm²)"
Columns(iCol).ColumnWidth = Len("Atis (µm²)")
'Paste each column into all column
For iRangeCnt = LBound(aRangeAtis) To UBound(aRangeAtis)
aRangeAtis(iRangeCnt).Select
Selection.Copy
'Find last row of destination column
Columns(iCol).End(xlDown).Select
lEndRow = ActiveCell.Row
Cells(lEndRow + 1, iCol).Select
'Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
ActiveSheet.Paste
Next
'Find last row of destination column
Columns(iCol).End(xlDown).Select
lEndRow = ActiveCell.Row
'All column number format
Range(Cells(3, iCol), Cells(lEndRow, iCol)).NumberFormat = "0.0"
'All Atis descriptive statistics
Application.Run "ATPVBAEN.XLA!Descr", _
Range(Cells(2, iCol), Cells(lEndRow, iCol)), _
Cells(2, iCol + 1), "C", True, True
Columns(iCol + 1).ColumnWidth = 16 'stats col width
'Set numberformat for stats (limit range to keep count a whole number)
Range(Cells(3, iCol + 2), Cells(15, iCol + 2)).NumberFormat = "0.0"
End If
'Set the object variable to Nothing.
Set fd = Nothing
CenterColTitles
PageSetup
Cells(1, 1).Select 'Reset data sheet position
'Save workbook
'sFileSaveName = Application.GetSaveAsFilename(NewBook.Title & "_CL.xls", "Excel Files (*.xls), *.xls")
'If sFileSaveName <> "False" Then
On Error Resume Next 'ignore rte 1004 if No reply to overwrite
'NewBook.SaveAs sFileSaveName
NewBook.SaveAs fileName:=NewBook.Title & "_A.xls"
On Error GoTo err_AP_No_Edge_1
'End If
exit_AP_No_Edge_1:
Application.ScreenUpdating = True
Exit Sub
err_AP_No_Edge_1:
MsgBox Err.Description
Resume exit_AP_No_Edge_1
End Sub
Sub AP_With_Edge_1()
'Prompt for folder name
'For each area/perimeter (*_Aalv_e.TXT) file in the selected folder:
'Display data
'Display descriptive statistics in adjacent columns
'Leave blank column before next data column
On Error GoTo err_AP_With_Edge_1
Dim NewBook As Workbook
Dim NewSheet As Worksheet
Dim fd As FileDialog 'File Picker dialog box.
Dim vSelectedItem As Variant 'contains selected file path- variant required for For Each...Next
Dim sFileName() As String 'holds sorted filepaths
Dim sAirFileName As String
Dim sFileSaveName As String 'workbook save name
Dim i, iCol, iStartPos, iEndPos As Integer
Dim lEndRow As Long
Dim strColTitle As String
Dim aRangeAalv() As Range 'Array of ranges for Aalv
Dim aRangeAsur() As Range 'Array of ranges for Asurf
Dim aRangeAair() As Range 'Array of ranges for Aair
Dim aRangeAtis() As Range 'Array of ranges for Atis
Dim iRangeCnt As Integer 'Range array index
Dim lMeasCnt As Long 'Running total nr of measurements to prevent exceeding Excel row limit of 65536.
'Speed up macro execution (restored to True at exit)
Application.ScreenUpdating = False
'Load Analysis Toolpak if it is not currently loaded...
'The password to access function definintions is: Wildebeest
If fAddInLoaded("Analysis ToolPak - VBA") = -1 Then
' Error finding Analysis Toolpak...
MsgBox "Analysis ToolPak Not Found", vbExclamation
GoTo exit_AP_With_Edge_1
End If
'Setup file dialog
Set fd = Application.FileDialog(msoFileDialogFilePicker)
fd.InitialFileName = "*_Aalv_e.txt"
fd.Filters.Add "Area/perimeter measurement files", "*.txt", 1
'Use the Show method to display the File Picker dialog box and return the user's action.
'The user pressed the action button.
If fd.Show = -1 Then
'Add new workbook named as selected folder
Set NewBook = Workbooks.Add
'Extract folder name from path
iEndPos = InStrRev(fd.InitialFileName, "\") - 1
iStartPos = InStrRev(fd.InitialFileName, "\", iEndPos - 1) + 1
NewBook.Title = Mid$(fd.InitialFileName, iStartPos, iEndPos - iStartPos + 1)
'Moved to end: NewBook.SaveAs fileName:=NewBook.Title & "_A.xls"
'Add new worksheet
Set NewSheet = Worksheets.Add
NewSheet.Name = NewBook.Title
'Hide default sheets instead of deleting, to prevent warning
NewBook.Sheets("Sheet1").Visible = False
NewBook.Sheets("Sheet2").Visible = False
NewBook.Sheets("Sheet3").Visible = False
'Store FileDialogSelectedItems filename (text after last "\") in array then sort
i = 0
For Each vSelectedItem In fd.SelectedItems
i = i + 1
ReDim Preserve sFileName(i)
sFileName(i) = Mid$(vSelectedItem, InStrRev(vSelectedItem, "\") + 1)
Next
'If no files or valid filenames, exit
If i = 0 Then
MsgBox "No files to measure.", vbCritical, "Message"
GoTo exit_AP_With_Edge_1
End If
'Sort
SelectionSortStrings sFileName
iCol = 1
ReDim aRangeAalv(1)
ReDim aRangeAsur(1)
ReDim aRangeAair(1)
ReDim aRangeAtis(1)
iRangeCnt = LBound(aRangeAalv)
lMeasCnt = 0
For Each vSelectedItem In sFileName()
'Skip empty array elements
If vSelectedItem <> "" Then
'Extract selected file name from path for column label
iEndPos = InStrRev(vSelectedItem, ".")
iStartPos = InStrRev(vSelectedItem, "\", iEndPos - 1) + 1
'Include parent folder in group name
strColTitle = NewBook.Title & "\" & Mid$(vSelectedItem, iStartPos, iEndPos - iStartPos)
'strColTitle = Mid$(vSelectedItem, iStartPos, iEndPos - iStartPos)
'Import corresponding Aair_roi file
sAirFileName = Mid$(vSelectedItem, 1, InStrRev(vSelectedItem, "Aalv_e")) + "air_roi.txt"
With ActiveSheet.QueryTables.Add(Connection:="TEXT;" & sAirFileName, Destination:=ActiveSheet.Cells(1, (iCol)))
.Refresh
End With
'Find last row
Columns(iCol).End(xlDown).Select
lEndRow = ActiveCell.Row
'Aair scaled to microns in next column
Cells(1, iCol + 1).FormulaR1C1 = "=+RC[-1]*" & cSqMicronsPerPixel
Cells(1, iCol + 1).Select
Selection.Copy
Range(Cells(2, iCol + 1), Cells(lEndRow, iCol + 1)).Select
ActiveSheet.Paste
'Copy Aroi cell value (last value in column) into destination cell
Cells(3, iCol + 3) = Cells(lEndRow, iCol + 1).Value
'Sum Air and enter into its cell
Cells(6, iCol + 3) = WorksheetFunction.Sum(Range(Cells(1, iCol + 1), Cells(lEndRow - 1, iCol + 1)))
'Set column title, width and number format
Cells(2, iCol + 3).Value = "Aroi (µm²)"
Cells(5, iCol + 3).Value = "Aair (µm²)"
Columns(iCol + 3).ColumnWidth = Len("Aroi (µm²)")
Columns(iCol + 3).NumberFormat = "0.0"
'Delete raw and scaled Aair columns.
Range(Cells(1, iCol), Cells(lEndRow, iCol + 1)).Select
Selection.ClearContents
'Import area and perimeter data (pixels)
'Import resets column widths so do first
With ActiveSheet.QueryTables.Add(Connection:="TEXT;" & vSelectedItem, Destination:=ActiveSheet.Cells(3, (iCol)))
.Refresh
End With
'Column title and width
Cells(2, iCol).Value = "Aalv(px)"
Columns(iCol).ColumnWidth = Len("Aalv (px)")
'Asurf (pixels)
'Set column title
'(contiguous cells required to find last cell)
Cells(1, iCol + 1).Value = "."
Cells(2, iCol + 1).Value = "Asurf (px)"
'Find last row
Columns(iCol + 1).End(xlDown).Select
lEndRow = ActiveCell.Row
Cells(1, iCol + 1).Clear 'remove "."
'Move column over
Columns(iCol + 1).Select
Selection.Cut
ActiveSheet.Paste Columns(iCol + 6)
'Set column width and number format
'Columns(iCol + 6).ColumnWidth = Len("Asurf (px)")
'Range(Cells(3, iCol + 6), Cells(lEndRow - 1, iCol + 6)).NumberFormat = "0.0"
'Above commented because column will be overwritten
'Aalv scaled to microns
'lEndRow same as Asurf column
Cells(3, iCol + 1).FormulaR1C1 = "=+RC[-1]*" & cSqMicronsPerPixel
Cells(3, iCol + 1).Select
Selection.Copy
Range(Cells(4, iCol + 1), Cells(lEndRow, iCol + 1)).Select
ActiveSheet.Paste
'Overwrite raw data with scaled data, converting formulas to values
' (will not work with cut- use copy)
Range(Cells(2, iCol + 1), Cells(lEndRow, iCol + 1)).Select
Selection.Copy
Cells(2, iCol).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
'Delete source range
Range(Cells(2, iCol + 1), Cells(lEndRow, iCol + 1)).Select
Selection.ClearContents
'Set column title, width and number format
Cells(2, iCol).Value = "Aalv (µm²)"
Columns(iCol).ColumnWidth = Len("Aalv (µm²)")
Range(Cells(3, iCol), Cells(lEndRow, iCol)).NumberFormat = "0.0"
'If the total number of measurements exceeds Excel limit prompt and end macro.
'Although the imported column will contain fewer rows than the Excel limit,
'the Excel limit would be reached at the cut/paste into the All column stage.
'Quicker to prompt here.
lMeasCnt = lMeasCnt + Range(Cells(3, iCol), Cells(lEndRow, iCol)).Count
If lMeasCnt > 65536 Then
MsgBox "The total number of measurements has exceeded the Excel limit of 65536.", vbCritical
GoTo exit_AP_With_Edge_1
End If
'Aalv descriptive statistics (first row of range is column title)
Application.Run "ATPVBAEN.XLA!Descr", _
Range(Cells(2, iCol), Cells(lEndRow, iCol)), _
Cells(2, iCol + 1), "C", True, True
'Set column width
Columns(iCol + 1).ColumnWidth = 16
'Set number format except for count which remains an integer
Range(Cells(3, iCol + 2), Cells(15, iCol + 2)).NumberFormat = "0.0"
'Airspace percent (Aair/Aroi)
'Set column title, width and number format
Cells(2, iCol + 4).Value = "Aair (%)"
Columns(iCol + 4).ColumnWidth = Len("Aair (%)")
Cells(3, iCol + 4).NumberFormat = "0.0"
'Calculate value
'Cells(3, iCol + 4).FormulaR1C1 = "=SUM(C[-4])/(C[-1])*100"
'ActiveSheet.Calculate
Cells(3, iCol + 4) = (Cells(6, iCol + 3) / Cells(3, iCol + 3)) * 100
'Tissue area (Aroi - Aair)
'Set column title, width and number format
Cells(2, iCol + 5).Value = "Atis (µm²)"
Columns(iCol + 5).ColumnWidth = Len("Atis (µm²)")
Cells(3, iCol + 5).NumberFormat = "0.0"
'Calculate value
'Cells(3, iCol + 5).FormulaR1C1 = "=(C[-2])-SUM(C[-5])"
'ActiveSheet.Calculate
Cells(3, iCol + 5) = Cells(3, iCol + 3) - Cells(6, iCol + 3)
'Asurf scaled to microns (uses non-squared conversion factor because it is perimeter (length)
Cells(3, iCol + 7).FormulaR1C1 = "=+RC[-1]*" & cMicronsPerPixel
Cells(3, iCol + 7).Select
Selection.Copy
Range(Cells(4, iCol + 7), Cells(lEndRow, iCol + 7)).Select
ActiveSheet.Paste
'Overwrite raw data with scaled data, converting formulas to values
' (will not work with cut- use copy)
Range(Cells(2, iCol + 7), Cells(lEndRow, iCol + 7)).Select
Selection.Copy
Cells(2, iCol + 6).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
'Delete source range
Range(Cells(2, iCol + 7), Cells(lEndRow, iCol + 7)).Select
Selection.ClearContents
'Set column title, width and number format
Cells(2, iCol + 6).Value = "Asurf (µm)"
Columns(iCol + 6).ColumnWidth = Len("Asurf (µm)")
Range(Cells(3, iCol + 6), Cells(lEndRow, iCol + 6)).NumberFormat = "0.0"
'Asurf descriptive statistics (first row of range is column title)
Application.Run "ATPVBAEN.XLA!Descr", _
Range(Cells(2, iCol + 6), Cells(lEndRow, iCol + 6)), _
Cells(2, iCol + 7), "C", True, True
'Set column width
Columns(iCol + 7).ColumnWidth = 16
'Set number format for stats (limit range to keep Count a whole number)
Range(Cells(3, iCol + 8), Cells(15, iCol + 8)).NumberFormat = "0.0"
'Set blank column width
Columns(iCol + 9).ColumnWidth = 5
'Group title
'Done at end of loop because cells used for title need to have text
' added to make contiguous column for finding last cell. Once cells
' are merged to store title, cannot add text to B1 and could not find
' last cell in column.
'Range(Cells(1, iCol), Cells(1, iCol + 2)).Select
Cells(1, iCol).Select
With Selection
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = True
.Value = strColTitle
.Font.Bold = True
End With
'Store current range in array
ReDim Preserve aRangeAalv(UBound(aRangeAalv) + 1)
ReDim Preserve aRangeAsur(UBound(aRangeAsur) + 1)
ReDim Preserve aRangeAair(UBound(aRangeAair) + 1)
ReDim Preserve aRangeAtis(UBound(aRangeAtis) + 1)
Set aRangeAalv(iRangeCnt) = Range(Cells(3, iCol), Cells(lEndRow, iCol))
Set aRangeAsur(iRangeCnt) = Range(Cells(3, iCol + 6), Cells(lEndRow, iCol + 6))
Set aRangeAair(iRangeCnt) = Range(Cells(3, iCol + 4), Cells(3, iCol + 4))
Set aRangeAtis(iRangeCnt) = Range(Cells(3, iCol + 5), Cells(lEndRow, iCol + 5))
iRangeCnt = iRangeCnt + 1
iCol = iCol + 10
End If
Next vSelectedItem
'Truncate empty range elements
ReDim Preserve aRangeAalv(iRangeCnt - 1)
ReDim Preserve aRangeAsur(iRangeCnt - 1)
ReDim Preserve aRangeAair(iRangeCnt - 1)
ReDim Preserve aRangeAtis(iRangeCnt - 1)
'All Aalv column title and width
Cells(1, iCol).Value = "All Aalv"
Cells(1, iCol).Font.Bold = True
Cells(2, iCol).Value = "Aalv (µm²)"
Columns(iCol).ColumnWidth = Len("Aalv (µm²)")
'Move each column into all column
For iRangeCnt = LBound(aRangeAalv) To UBound(aRangeAalv)
aRangeAalv(iRangeCnt).Select
'Selection.Copy
Selection.Cut
'Find last row of destination column
Columns(iCol).End(xlDown).Select
lEndRow = ActiveCell.Row
Cells(lEndRow + 1, iCol).Select
'Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
ActiveSheet.Paste
Next
'Find last row of destination column
Columns(iCol).End(xlDown).Select
lEndRow = ActiveCell.Row
'All column number format
Range(Cells(3, iCol), Cells(lEndRow, iCol)).NumberFormat = "0.0"
'All Aalv descriptive statistics
Application.Run "ATPVBAEN.XLA!Descr", _
Range(Cells(2, iCol), Cells(lEndRow, iCol)), _
Cells(2, iCol + 1), "C", True, True
Columns(iCol + 1).ColumnWidth = 16 'stats col width
'Set numberformat for stats (limit range to keep count a whole number)
Range(Cells(3, iCol + 2), Cells(15, iCol + 2)).NumberFormat = "0.0"
iCol = iCol + 4
'All Asurf column title and width
Cells(1, iCol).Value = "All Asurf"
Cells(1, iCol).Font.Bold = True
Cells(2, iCol).Value = "Asurf (µm)"
Columns(iCol).ColumnWidth = Len("Asurf (µm)")
'Paste each column into all column
For iRangeCnt = LBound(aRangeAsur) To UBound(aRangeAsur)
aRangeAsur(iRangeCnt).Select
'Selection.Copy
Selection.Cut
'Find last row of destination column
Columns(iCol).End(xlDown).Select
lEndRow = ActiveCell.Row
Cells(lEndRow + 1, iCol).Select
'Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
ActiveSheet.Paste
Next
'Find last row of destination column
Columns(iCol).End(xlDown).Select
lEndRow = ActiveCell.Row
'All column number format
Range(Cells(3, iCol), Cells(lEndRow, iCol)).NumberFormat = "0.0"
'All Asurf descriptive statistics
Application.Run "ATPVBAEN.XLA!Descr", _
Range(Cells(2, iCol), Cells(lEndRow, iCol)), _
Cells(2, iCol + 1), "C", True, True
Columns(iCol + 1).ColumnWidth = 16 'stats col width
'Set numberformat for stats (limit range to keep count a whole number)
Range(Cells(3, iCol + 2), Cells(15, iCol + 2)).NumberFormat = "0.0"
iCol = iCol + 4
'All Aair% column title and width
Cells(1, iCol).Value = "All Aair"
Cells(1, iCol).Font.Bold = True
Cells(2, iCol).Value = "Aair (%)"
Columns(iCol).ColumnWidth = Len("Aair (%)")
'Paste each column into all column
For iRangeCnt = LBound(aRangeAair) To UBound(aRangeAair)
aRangeAair(iRangeCnt).Select
Selection.Copy
'Find last row of destination column
Columns(iCol).End(xlDown).Select
lEndRow = ActiveCell.Row
Cells(lEndRow + 1, iCol).Select
'Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
ActiveSheet.Paste
Next
'Find last row of destination column
Columns(iCol).End(xlDown).Select
lEndRow = ActiveCell.Row
'All column number format
Range(Cells(3, iCol), Cells(lEndRow, iCol)).NumberFormat = "0.0"
'All Aair descriptive statistics
Application.Run "ATPVBAEN.XLA!Descr", _
Range(Cells(2, iCol), Cells(lEndRow, iCol)), _
Cells(2, iCol + 1), "C", True, True
Columns(iCol + 1).ColumnWidth = 16 'stats col width
'Set numberformat for stats (limit range to keep count a whole number)
Range(Cells(3, iCol + 2), Cells(15, iCol + 2)).NumberFormat = "0.0"
iCol = iCol + 4
'All Atis% column title and width
'Values are calculate from preceding Aair column
Cells(1, iCol).Value = "All Atis"
Cells(1, iCol).Font.Bold = True
Cells(2, iCol).Value = "Atis (%)"
Columns(iCol).ColumnWidth = Len("Atis (%)")
'Atis % = 100-Aair%
Cells(3, iCol).FormulaR1C1 = "=100-(+RC[-4])"
Cells(3, iCol).Select
Selection.Copy
Range(Cells(3, iCol), Cells(lEndRow, iCol)).Select 'Endrow from Aair column
ActiveSheet.Paste
'Convert formulas to values
Range(Cells(3, iCol), Cells(lEndRow, iCol)).Select
Selection.Copy
Cells(3, iCol).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
'All column number format
Range(Cells(3, iCol), Cells(lEndRow, iCol)).NumberFormat = "0.0"
'All Aair descriptive statistics
Application.Run "ATPVBAEN.XLA!Descr", _
Range(Cells(2, iCol), Cells(lEndRow, iCol)), _
Cells(2, iCol + 1), "C", True, True
Columns(iCol + 1).ColumnWidth = 16 'stats col width
'Set numberformat for stats (limit range to keep count a whole number)
Range(Cells(3, iCol + 2), Cells(15, iCol + 2)).NumberFormat = "0.0"
iCol = iCol + 4
'All Atis column title and width
Cells(1, iCol).Value = "All Atis"
Cells(1, iCol).Font.Bold = True
Cells(2, iCol).Value = "Atis (µm²)"
Columns(iCol).ColumnWidth = Len("Atis (µm²)")
'Paste each column into all column
For iRangeCnt = LBound(aRangeAtis) To UBound(aRangeAtis)
aRangeAtis(iRangeCnt).Select
Selection.Copy
'Find last row of destination column
Columns(iCol).End(xlDown).Select
lEndRow = ActiveCell.Row
Cells(lEndRow + 1, iCol).Select
'Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
ActiveSheet.Paste
Next
'Find last row of destination column
Columns(iCol).End(xlDown).Select
lEndRow = ActiveCell.Row
'All column number format
Range(Cells(3, iCol), Cells(lEndRow, iCol)).NumberFormat = "0.0"
'All Atis descriptive statistics
Application.Run "ATPVBAEN.XLA!Descr", _
Range(Cells(2, iCol), Cells(lEndRow, iCol)), _
Cells(2, iCol + 1), "C", True, True
Columns(iCol + 1).ColumnWidth = 16 'stats col width
'Set numberformat for stats (limit range to keep count a whole number)
Range(Cells(3, iCol + 2), Cells(15, iCol + 2)).NumberFormat = "0.0"
End If
'Set the object variable to Nothing.
Set fd = Nothing
CenterColTitles
PageSetup
Cells(1, 1).Select 'Reset data sheet position
'Save workbook
'sFileSaveName = Application.GetSaveAsFilename(NewBook.Title & "_CL.xls", "Excel Files (*.xls), *.xls")
'If sFileSaveName <> "False" Then
On Error Resume Next 'ignore rte 1004 if No reply to overwrite
'NewBook.SaveAs sFileSaveName
NewBook.SaveAs fileName:=NewBook.Title & "_Ae.xls"
On Error GoTo err_AP_With_Edge_1
'End If
exit_AP_With_Edge_1:
Application.ScreenUpdating = True
Exit Sub
err_AP_With_Edge_1:
MsgBox Err.Description
Resume exit_AP_With_Edge_1
End Sub
Sub CL_Air_Multi()
'Open folder picker filedialog box
'For each selected folder:
'For each selected chord length (*_CLa.TXT) file in the selected folder:
'Display data
'Display descriptive statistics in adjacent columns
'Move data from each column into 'All' column and display descriptive stats
'Move 'All' column into Histo sheet
On Error GoTo err_CL_Air_Multi
Dim NewBook As Workbook
Dim NewSheet As Worksheet
Dim fd As FileDialog 'Folder picker dialog
Dim vSelectedItem As Variant 'contains selected file path- variant required for For Each...Next
Dim fs As FileSearch 'used with file searches-returns founditems
Dim vFoundItem As Variant 'contains file paths found in vSelectedItem
Dim sFolderName() As String 'folder names array
Dim sFileName() As String 'file names array
Dim sFileSaveName As String 'workbook save name
Dim i As Integer 'loop counter
Dim iCol As Integer 'Data sheet column position
Dim lEndRow As Long
Dim iAllStatsRow, iAllDataCol, iAllStatsCol, iAllMeansRow, iAllMeansCol As Integer ''All' sheet position
Dim iStartPos, iEndPos As Integer 'string parsing
Dim strColTitle As String
Dim aRange() As Range 'Array of ranges
Dim iRangeCnt As Integer 'Range array index
Dim iDupCnt As Integer
Dim lMeasCnt As Long 'Running total nr of measurements to prevent exceeding Excel row limit of 65536.
'Load Analysis Toolpak if it is not currently loaded...
'The password to access function definintions is: Wildebeest
If fAddInLoaded("Analysis ToolPak - VBA") = -1 Then
' Error finding Analysis Toolpak...
MsgBox "Analysis ToolPak Not Found", vbExclamation
GoTo exit_CL_Air_Multi
End If
Set fd = Application.FileDialog(msoFileDialogFolderPicker)
'Add unnamed new workbook
Set NewBook = Workbooks.Add
'Create new sheet for file info
Set NewSheet = Worksheets.Add
NewSheet.Name = "Info"
iDupCnt = 1
'Hide default sheets instead of deleting, to prevent warning
NewBook.Sheets("Sheet1").Visible = False
NewBook.Sheets("Sheet2").Visible = False
NewBook.Sheets("Sheet3").Visible = False
'Folder picker dialog does not allow multiple selection (unlike
' file picker), so store each separate folder selection in array.
'Cancel button ends selection loop.
i = 0
Do
'Show Folder Picker dialog. Returns -1 if selection made, 0 if canceled
If fd.Show = 0 Then
Exit Do
Else
i = i + 1
ReDim Preserve sFolderName(i)
sFolderName(i) = fd.SelectedItems.Item(1)
Worksheets("Info").Cells(i, 1) = Mid$(sFolderName(i), InStrRev(sFolderName(i), "\") + 1)
End If
Loop
'If no folder selected, exit
If i = 0 Then GoTo exit_CL_Air_Multi
'Disable screen update to speed up macro execution (restored to True at exit)
' (do after folder picker so selected folders are shown on Info sheet).
Application.ScreenUpdating = False
'Extract parent folder name from first selected folder to use as file name
iEndPos = InStrRev(sFolderName(1), "\") - 1
iStartPos = InStrRev(sFolderName(1), "\", iEndPos - 1) + 1
NewBook.Title = Mid$(sFolderName(1), iStartPos, iEndPos - iStartPos + 1)
'Create new sheet for All data
Set NewSheet = Worksheets.Add
NewSheet.Name = "All CL"
Set fs = Application.FileSearch
iAllDataCol = 0
iAllStatsRow = 1
iAllStatsCol = UBound(sFolderName) + 3
iAllMeansCol = iAllStatsCol + 3
iAllMeansRow = 2
For Each vSelectedItem In sFolderName()
'Search for files in selected folder
With fs
.NewSearch
.LookIn = vSelectedItem
.SearchSubFolders = False
.fileName = "*_CLa.txt"
If .Execute > 0 Then
'Store found files filename (text after last "\") in array then sort
i = 0
For Each vFoundItem In .FoundFiles
i = i + 1
ReDim Preserve sFileName(i)
sFileName(i) = Mid$(vFoundItem, InStrRev(vFoundItem, "\") + 1)
Next
'If no files or valid filenames, exit
If i = 0 Then
MsgBox "No files to measure.", vbCritical, "Message"
GoTo exit_CL_Air_Multi
End If
SelectionSortStrings sFileName
'Create new sheet
Set NewSheet = Worksheets.Add
NewSheet.Name = Mid$(vSelectedItem, InStrRev(vSelectedItem, "\") + 1)
iCol = 1
ReDim aRange(1)
iRangeCnt = LBound(aRange)
lMeasCnt = 0
'For each file in sorted array
For Each vFoundItem In sFileName()
'Extract selected file name from path for column label
iEndPos = InStrRev(vFoundItem, ".")
iStartPos = InStrRev(vFoundItem, "\", iEndPos - 1) + 1
'Include parent folder in group name
strColTitle = NewSheet.Name & "\" & Mid$(vFoundItem, iStartPos, iEndPos - iStartPos)
'strColTitle = Mid$(vFoundItem, iStartPos, iEndPos - iStartPos)
'Import chord length data (pixels)
'Import resets column widths so do first
With ActiveSheet.QueryTables.Add(Connection:="TEXT;" & vSelectedItem & "\" & vFoundItem, _
Destination:=ActiveSheet.Cells(3, (iCol)))
.Refresh
End With
'Column title and width
Cells(2, iCol).Value = "CL (px)"
Columns(iCol).ColumnWidth = Len("CL (px)")
'Group title
'Range(Cells(1, iCol), Cells(1, iCol + 2)).Select
Cells(1, iCol).Select
With Selection
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = True
.Value = strColTitle
.Font.Bold = True
End With
'Chord length scaled in microns
Cells(2, iCol + 1).Value = "CL (µm)"
Columns(iCol + 1).ColumnWidth = Len("CL (µm)")
'Create formula and copy to new range
Cells(3, iCol + 1).FormulaR1C1 = "=+RC[-1]*" & cMicronsPerPixel
Cells(3, iCol + 1).Select
Selection.Copy
Columns(iCol).End(xlDown).Select
lEndRow = ActiveCell.Row
Range(Cells(4, iCol + 1), Cells(lEndRow, iCol + 1)).Select
ActiveSheet.Paste
'Copy scaled data over raw data, converting formulas to values
' (will not work with cut- use copy)
Range(Cells(2, iCol + 1), Cells(lEndRow, iCol + 1)).Select
Selection.Copy
Cells(2, iCol).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
'Delete source range
Range(Cells(2, iCol + 1), Cells(lEndRow, iCol + 1)).Select
Selection.ClearContents
'Number format for scaled data
Range(Cells(3, iCol), Cells(lEndRow, iCol)).NumberFormat = "0.0"
'If the total number of measurements exceeds Excel limit prompt and end macro.
'Although the imported column will contain fewer rows than the Excel limit,
'the Excel limit would be reached at the cut/paste into the All column stage.
'Quicker to prompt here.
lMeasCnt = lMeasCnt + Range(Cells(3, iCol), Cells(lEndRow, iCol)).Count
If lMeasCnt > 65536 Then
MsgBox "The total number of measurements has exceeded the Excel limit of 65536.", vbCritical
GoTo exit_CL_Air_Multi
End If
'Descriptive statistics
'Descr function: input range, output range, grouped, labels, summary, ds_large, ds_small, confidence
'Grouped="C" for columns, "R" for rows
Application.Run "ATPVBAEN.XLA!Descr", _
Range(Cells(2, iCol), Cells(lEndRow, iCol)), _
Cells(2, iCol + 1), "C", True, True
Columns(iCol + 1).ColumnWidth = 16 'stats col width
'Set numberformat for stats (limit range to keep count a whole number)
Range(Cells(3, iCol + 2), Cells(15, iCol + 2)).NumberFormat = "0.0"
Columns(iCol + 3).ColumnWidth = 5 'Blank column width
'Store current range in array
ReDim Preserve aRange(UBound(aRange) + 1)
Set aRange(iRangeCnt) = Range(Cells(3, iCol), Cells(lEndRow, iCol))
iRangeCnt = iRangeCnt + 1
iCol = iCol + 4
Next vFoundItem
'Truncate empty range element
ReDim Preserve aRange(iRangeCnt - 1)
'All column title and width
Cells(1, iCol).Value = "All"
Cells(1, iCol).Font.Bold = True
Cells(2, iCol).Value = "CL (µm)"
Columns(iCol).ColumnWidth = Len("CL (µm)")
'Paste each column into all column
For iRangeCnt = LBound(aRange) To UBound(aRange)
aRange(iRangeCnt).Select
'Selection.Copy
Selection.Cut
'Find last row of destination column
Columns(iCol).End(xlDown).Select
lEndRow = ActiveCell.Row
Cells(lEndRow + 1, iCol).Select
'Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
ActiveSheet.Paste
Next
'Find last row of destination column
Columns(iCol).End(xlDown).Select
lEndRow = ActiveCell.Row
'All column number format
Range(Cells(3, iCol), Cells(lEndRow, iCol)).NumberFormat = "0.0"
'All CL descriptive statistics
Application.Run "ATPVBAEN.XLA!Descr", _
Range(Cells(2, iCol), Cells(lEndRow, iCol)), _
Cells(2, iCol + 1), "C", True, True
Columns(iCol + 1).ColumnWidth = 16 'stats col width
'Set numberformat for stats (limit range to keep count a whole number)
Range(Cells(3, iCol + 2), Cells(15, iCol + 2)).NumberFormat = "0.0"
CenterColTitles
PageSetup
'Move All data to All sheet in first available column
Range(Cells(3, iCol), Cells(lEndRow, iCol)).Select
Selection.Cut
Worksheets("All CL").Activate
iAllDataCol = iAllDataCol + 1
Cells(2, iAllDataCol).Select
ActiveSheet.Paste
'Reserve row 1 for titles
Cells(1, iAllDataCol).Font.Bold = True
Cells(1, iAllDataCol).Value = NewSheet.Name
'Move All stats to All sheet
'NewSheet.Name still refers to data sheet since it was the last sheet created
Worksheets(NewSheet.Name).Activate
Range(Cells(2, iCol + 1), Cells(16, iCol + 2)).Select
Selection.Copy
Cells(1, 1).Select 'Reset data sheet position
Worksheets("All CL").Activate
Cells(iAllStatsRow + 1, iAllStatsCol).Select
ActiveSheet.Paste
Columns(iAllStatsCol).ColumnWidth = 16 'stats col width
Columns(iAllStatsCol + 1).ColumnWidth = 12
'Group title
Cells(iAllStatsRow, iAllStatsCol).Select
With Selection
.Value = NewSheet.Name & " (All)"
.Font.Bold = True
End With
'Copy mean value into All Means column
'Group title
Cells(1, iAllMeansCol).Value = "All Means"
Cells(1, iAllMeansCol).Font.Bold = True
'Copy group stats mean into All Means column
Cells(iAllStatsRow + 3, iAllStatsCol + 1).Select
Selection.Copy
Cells(iAllMeansRow, iAllMeansCol).Select
ActiveSheet.Paste
iAllMeansRow = iAllMeansRow + 1
'Increment to next group stats row
iAllStatsRow = iAllStatsRow + 17
Else
MsgBox "No files found in folder " & vSelectedItem, vbExclamation, "Message"
End If
End With
Next vSelectedItem
'All means
iCol = iAllMeansCol
'Find last row of destination column
Columns(iCol).End(xlDown).Select
lEndRow = ActiveCell.Row
'All column number format
Range(Cells(1, iCol), Cells(lEndRow, iCol)).NumberFormat = "0.0"
'Descriptive statistics
Application.Run "ATPVBAEN.XLA!Descr", _
Range(Cells(1, iCol), Cells(lEndRow, iCol)), _
Cells(1, iCol + 1), "C", True, True
Columns(iCol + 1).ColumnWidth = 16 'stats col width
'Set numberformat for stats (limit range to keep count a whole number)
Range(Cells(3, iCol + 2), Cells(14, iCol + 2)).NumberFormat = "0.0"
'end of All means
Cells(1, 1).Select 'Move to home position in all sheet
'Set object variables to Nothing.
Set fd = Nothing
Set fs = Nothing
'Save workbook
sFileSaveName = Application.GetSaveAsFilename(NewBook.Title & "_CLa.xls", "Excel Files (*.xls), *.xls")
If sFileSaveName <> "False" Then
On Error Resume Next 'ignore rte 1004 if No reply to overwrite
NewBook.SaveAs sFileSaveName
'NewBook.SaveAs fileName:=NewBook.Title & "_CL.xls"
On Error GoTo err_CL_Air_Multi
End If
exit_CL_Air_Multi:
Application.ScreenUpdating = True
Exit Sub
err_CL_Air_Multi:
'If same folder chosen (only when testing) increment the sheet name to prevent duplicate sheet error.
If Left(Err.Description, 55) = "Cannot rename a sheet to the same name as another sheet" Then
NewSheet.Name = Mid$(vSelectedItem, InStrRev(vSelectedItem, "\") + 1) & " Copy" & iDupCnt
iDupCnt = iDupCnt + 1
Resume Next
Else
MsgBox Err.Description
Resume exit_CL_Air_Multi
End If
End Sub
Sub CL_Tissue_Multi()
'Open folder picker filedialog box
'For each selected folder:
'For each selected chord length (*_CLt.TXT) file in the selected folder:
'Display data
'Display descriptive statistics in adjacent columns
'Move data from each column into 'All' column and display descriptive stats
'Move 'All' column into Histo sheet
On Error GoTo err_CL_Tissue_Multi
Dim NewBook As Workbook
Dim NewSheet As Worksheet
Dim fd As FileDialog 'Folder picker dialog
Dim vSelectedItem As Variant 'contains selected file path- variant required for For Each...Next
Dim fs As FileSearch 'used with file searches-returns founditems
Dim vFoundItem As Variant 'contains file paths found in vSelectedItem
Dim sFolderName() As String 'folder names array
Dim sFileName() As String 'file names array
Dim sFileSaveName As String 'workbook save name
Dim i As Integer 'loop counter
Dim iCol As Integer 'Data sheet column position
Dim lEndRow As Long
Dim iAllStatsRow, iAllDataCol, iAllStatsCol, iAllMeansRow, iAllMeansCol As Integer ''All' sheet position
Dim iStartPos, iEndPos As Integer 'string parsing
Dim strColTitle As String
Dim aRange() As Range 'Array of ranges
Dim iRangeCnt As Integer 'Range array index
Dim iDupCnt As Integer 'Counter for handling duplicate sheet name error
Dim lMeasCnt As Long 'Running total nr of measurements to prevent exceeding Excel row limit of 65536.
'Load Analysis Toolpak if it is not currently loaded...
'The password to access function definintions is: Wildebeest
If fAddInLoaded("Analysis ToolPak - VBA") = -1 Then
' Error finding Analysis Toolpak...
MsgBox "Analysis ToolPak Not Found", vbExclamation
GoTo exit_CL_Tissue_Multi
End If
Set fd = Application.FileDialog(msoFileDialogFolderPicker)
'Add unnamed new workbook
Set NewBook = Workbooks.Add
'Create new sheet for file info
Set NewSheet = Worksheets.Add
NewSheet.Name = "Info"
iDupCnt = 1
'Hide default sheets instead of deleting, to prevent warning
NewBook.Sheets("Sheet1").Visible = False
NewBook.Sheets("Sheet2").Visible = False
NewBook.Sheets("Sheet3").Visible = False
'Folder picker dialog does not allow multiple selection (unlike
' file picker), so store each separate folder selection in array.
'Cancel button ends selection loop.
i = 0
Do
'Show Folder Picker dialog. Returns -1 if selection made, 0 if canceled
If fd.Show = 0 Then
Exit Do
Else
i = i + 1
ReDim Preserve sFolderName(i)
sFolderName(i) = fd.SelectedItems.Item(1)
Worksheets("Info").Cells(i, 1) = Mid$(sFolderName(i), InStrRev(sFolderName(i), "\") + 1)
End If
Loop
'If no folder selected, exit
If i = 0 Then GoTo exit_CL_Tissue_Multi
'Disable screen update to speed up macro execution (restored to True at exit)
' (do after folder picker so selected folders are shown on Info sheet).
Application.ScreenUpdating = False
'Extract parent folder name from first selected folder to use as file name
iEndPos = InStrRev(sFolderName(1), "\") - 1
iStartPos = InStrRev(sFolderName(1), "\", iEndPos - 1) + 1
NewBook.Title = Mid$(sFolderName(1), iStartPos, iEndPos - iStartPos + 1)
'Create new sheet for All data
Set NewSheet = Worksheets.Add
NewSheet.Name = "All CL"
Set fs = Application.FileSearch
iAllDataCol = 0
iAllStatsRow = 1
iAllStatsCol = UBound(sFolderName) + 3
iAllMeansCol = iAllStatsCol + 3
iAllMeansRow = 2
For Each vSelectedItem In sFolderName()
'Search for files in selected folder
With fs
.NewSearch
.LookIn = vSelectedItem
.SearchSubFolders = False
.fileName = "*_CLt.txt"
If .Execute > 0 Then
'Store found files filename (text after last "\") in array then sort
i = 0
For Each vFoundItem In .FoundFiles
i = i + 1
ReDim Preserve sFileName(i)
sFileName(i) = Mid$(vFoundItem, InStrRev(vFoundItem, "\") + 1)
Next
'If no files or valid filenames, exit
If i = 0 Then
MsgBox "No files to measure.", vbCritical, "Message"
GoTo exit_CL_Tissue_Multi
End If
SelectionSortStrings sFileName
'Create new sheet
Set NewSheet = Worksheets.Add
NewSheet.Name = Mid$(vSelectedItem, InStrRev(vSelectedItem, "\") + 1)
iCol = 1
ReDim aRange(1)
iRangeCnt = LBound(aRange)
lMeasCnt = 0
'For each file in sorted array
For Each vFoundItem In sFileName()
'Extract selected file name from path for column label
iEndPos = InStrRev(vFoundItem, ".")
iStartPos = InStrRev(vFoundItem, "\", iEndPos - 1) + 1
'Include parent folder in group name
strColTitle = NewSheet.Name & "\" & Mid$(vFoundItem, iStartPos, iEndPos - iStartPos)
'strColTitle = Mid$(vFoundItem, iStartPos, iEndPos - iStartPos)
'Import chord length data (pixels)
'Import resets column widths so do first
With ActiveSheet.QueryTables.Add(Connection:="TEXT;" & vSelectedItem & "\" & vFoundItem, _
Destination:=ActiveSheet.Cells(3, (iCol)))
.Refresh
End With
'Column title and width
Cells(2, iCol).Value = "CL (px)"
Columns(iCol).ColumnWidth = Len("CL (px)")
'Group title
'Range(Cells(1, iCol), Cells(1, iCol + 2)).Select
Cells(1, iCol).Select
With Selection
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = True
.Value = strColTitle
.Font.Bold = True
End With
'Chord length scaled in microns
Cells(2, iCol + 1).Value = "CL (µm)"
Columns(iCol + 1).ColumnWidth = Len("CL (µm)")
'Create formula and copy to new range
Cells(3, iCol + 1).FormulaR1C1 = "=+RC[-1]*" & cMicronsPerPixel
Cells(3, iCol + 1).Select
Selection.Copy
Columns(iCol).End(xlDown).Select
lEndRow = ActiveCell.Row
Range(Cells(4, iCol + 1), Cells(lEndRow, iCol + 1)).Select
ActiveSheet.Paste
'Copy scaled data over raw data, converting formulas to values
' (will not work with cut- use copy)
Range(Cells(2, iCol + 1), Cells(lEndRow, iCol + 1)).Select
Selection.Copy
Cells(2, iCol).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
'Delete source range
Range(Cells(2, iCol + 1), Cells(lEndRow, iCol + 1)).Select
Selection.ClearContents
'Number format for scaled data
Range(Cells(3, iCol), Cells(lEndRow, iCol)).NumberFormat = "0.0"
'If the total number of measurements exceeds Excel limit prompt and end macro.
'Although the imported column will contain fewer rows than the Excel limit,
'the Excel limit would be reached at the cut/paste into the All column stage.
'Quicker to prompt here.
lMeasCnt = lMeasCnt + Range(Cells(3, iCol), Cells(lEndRow, iCol)).Count
If lMeasCnt > 65536 Then
MsgBox "The total number of measurements has exceeded the Excel limit of 65536.", vbCritical
GoTo exit_CL_Tissue_Multi
End If
'Descriptive statistics
'Descr function: input range, output range, grouped, labels, summary, ds_large, ds_small, confidence
'Grouped="C" for columns, "R" for rows
Application.Run "ATPVBAEN.XLA!Descr", _
Range(Cells(2, iCol), Cells(lEndRow, iCol)), _
Cells(2, iCol + 1), "C", True, True
Columns(iCol + 1).ColumnWidth = 16 'stats col width
'Set numberformat for stats (limit range to keep count a whole number)
Range(Cells(3, iCol + 2), Cells(15, iCol + 2)).NumberFormat = "0.0"
Columns(iCol + 3).ColumnWidth = 5 'Blank column width
'Store current range in array
ReDim Preserve aRange(UBound(aRange) + 1)
Set aRange(iRangeCnt) = Range(Cells(3, iCol), Cells(lEndRow, iCol))
iRangeCnt = iRangeCnt + 1
iCol = iCol + 4
Next vFoundItem
'Truncate empty range element
ReDim Preserve aRange(iRangeCnt - 1)
'All column title and width
Cells(1, iCol).Value = "All"
Cells(1, iCol).Font.Bold = True
Cells(2, iCol).Value = "CL (µm)"
Columns(iCol).ColumnWidth = Len("CL (µm)")
'Paste each column into all column
For iRangeCnt = LBound(aRange) To UBound(aRange)
aRange(iRangeCnt).Select
'Selection.Copy
Selection.Cut
'Find last row of destination column
Columns(iCol).End(xlDown).Select
lEndRow = ActiveCell.Row
Cells(lEndRow + 1, iCol).Select
'Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
ActiveSheet.Paste
Next
'Find last row of destination column
Columns(iCol).End(xlDown).Select
lEndRow = ActiveCell.Row
'All column number format
Range(Cells(3, iCol), Cells(lEndRow, iCol)).NumberFormat = "0.0"
'All CL descriptive statistics
Application.Run "ATPVBAEN.XLA!Descr", _
Range(Cells(2, iCol), Cells(lEndRow, iCol)), _
Cells(2, iCol + 1), "C", True, True
Columns(iCol + 1).ColumnWidth = 16 'stats col width
'Set numberformat for stats (limit range to keep count a whole number)
Range(Cells(3, iCol + 2), Cells(15, iCol + 2)).NumberFormat = "0.0"
CenterColTitles
PageSetup
'Move All data to All sheet in first available column
Range(Cells(3, iCol), Cells(lEndRow, iCol)).Select
Selection.Cut
Worksheets("All CL").Activate
iAllDataCol = iAllDataCol + 1
Cells(2, iAllDataCol).Select
ActiveSheet.Paste
'Reserve row 1 for titles
Cells(1, iAllDataCol).Font.Bold = True
Cells(1, iAllDataCol).Value = NewSheet.Name
'Move All stats to All sheet
'NewSheet.Name still refers to data sheet since it was the last sheet created
Worksheets(NewSheet.Name).Activate
Range(Cells(2, iCol + 1), Cells(16, iCol + 2)).Select
Selection.Copy
Cells(1, 1).Select 'Reset data sheet position
Worksheets("All CL").Activate
Cells(iAllStatsRow + 1, iAllStatsCol).Select
ActiveSheet.Paste
Columns(iAllStatsCol).ColumnWidth = 16 'stats col width
Columns(iAllStatsCol + 1).ColumnWidth = 12
'Group title
Cells(iAllStatsRow, iAllStatsCol).Select
With Selection
.Value = NewSheet.Name & " (All)"
.Font.Bold = True
End With
'Copy mean value into All Means column
'Group title
Cells(1, iAllMeansCol).Value = "All Means"
Cells(1, iAllMeansCol).Font.Bold = True
'Copy group stats mean into All Means column
Cells(iAllStatsRow + 3, iAllStatsCol + 1).Select
Selection.Copy
Cells(iAllMeansRow, iAllMeansCol).Select
ActiveSheet.Paste
iAllMeansRow = iAllMeansRow + 1
'Increment to next groups stats row
iAllStatsRow = iAllStatsRow + 17
Else
MsgBox "No files found in folder " & vSelectedItem, vbExclamation, "Message"
End If
End With
Next vSelectedItem
'All means
iCol = iAllMeansCol
'Find last row of destination column
Columns(iCol).End(xlDown).Select
lEndRow = ActiveCell.Row
'All column number format
Range(Cells(1, iCol), Cells(lEndRow, iCol)).NumberFormat = "0.0"
'Descriptive statistics
Application.Run "ATPVBAEN.XLA!Descr", _
Range(Cells(1, iCol), Cells(lEndRow, iCol)), _
Cells(1, iCol + 1), "C", True, True
Columns(iCol + 1).ColumnWidth = 16 'stats col width
'Set numberformat for stats (limit range to keep count a whole number)
Range(Cells(3, iCol + 2), Cells(14, iCol + 2)).NumberFormat = "0.0"
'end of All means
Cells(1, 1).Select 'Move to home position in all sheet
'Set object variables to Nothing.
Set fd = Nothing
Set fs = Nothing
'Save workbook
sFileSaveName = Application.GetSaveAsFilename(NewBook.Title & "_CLt.xls", "Excel Files (*.xls), *.xls")
If sFileSaveName <> "False" Then
On Error Resume Next 'ignore rte 1004 if No reply to overwrite
NewBook.SaveAs sFileSaveName
'NewBook.SaveAs fileName:=NewBook.Title & "_CL.xls"
On Error GoTo err_CL_Tissue_Multi
End If
exit_CL_Tissue_Multi:
Application.ScreenUpdating = True
Exit Sub
err_CL_Tissue_Multi:
'If same folder chosen (only when testing) increment the sheet name to prevent duplicate sheet error.
If Left(Err.Description, 55) = "Cannot rename a sheet to the same name as another sheet" Then
NewSheet.Name = Mid$(vSelectedItem, InStrRev(vSelectedItem, "\") + 1) & " Copy" & iDupCnt
iDupCnt = iDupCnt + 1
Resume Next
Else
MsgBox Err.Description
Resume exit_CL_Tissue_Multi
End If
End Sub
Sub AP_With_Edge_Multi()
'Open folderpicker filedialog box
'For each selected folder:
'For each area/perimeter (*_Aalv_e.TXT) file in the selected folder:
'Display data
'Display descriptive statistics in adjacent columns
'Move data from each column into 'All' column and display descriptive stats
'Move 'All' column into separate sheets: Aalv, Asurf, Aair, Atis%, Atis
On Error GoTo err_AP_With_Edge_Multi
Dim NewBook As Workbook
Dim NewSheet As Worksheet
Dim fd As FileDialog 'file/folder picker dialog
Dim vSelectedItem As Variant 'contains selected file path- variant required for For Each...Next
Dim fs As FileSearch 'used with file searches-returns founditems
Dim vFoundItem As Variant 'contains file paths found in vSelectedItem
Dim sFolderName() As String 'folder names array
Dim sFileName() As String 'file names array
Dim sAirFileName As String
Dim sFileSaveName As String 'workbook save name
Dim iFileNum As Integer
Dim iFileNumMax As Integer
Dim iDupCnt As Integer 'Counter for handling duplicate sheet name error
Dim i As Integer 'loop counter
Dim iCol As Integer 'Data sheet position
Dim lEndRow As Long
Dim iAllStatsRow, iAllDataCol, iAllStatsCol, iAllMeansRow, iAllMeansCol As Integer ''All' sheet position
Dim iStartPos, iEndPos As Integer 'string parsing
Dim strColTitle As String
Dim aRangeAalv() As Range 'Array of ranges for Aalv
Dim aRangeAsur() As Range 'Array of ranges for Asurf
Dim aRangeAair() As Range 'Array of ranges for Aair
Dim aRangeAtis() As Range 'Array of ranges for Atis
Dim iRangeCnt As Integer 'Range array index
Dim lMeasCnt As Long 'Running total nr of measurements to prevent exceeding Excel row limit of 65536.
'Load Analysis Toolpak if it is not currently loaded...
'The password to access function definintions is: Wildebeest
If fAddInLoaded("Analysis ToolPak - VBA") = -1 Then
' Error finding Analysis Toolpak...
MsgBox "Analysis ToolPak Not Found", vbExclamation
GoTo exit_AP_With_Edge_Multi
End If
Set fd = Application.FileDialog(msoFileDialogFolderPicker)
'Add unnamed new workbook
Set NewBook = Workbooks.Add
'Create new sheet for file info
Set NewSheet = Worksheets.Add
NewSheet.Name = "Info"
iDupCnt = 1
'Hide default sheets instead of deleting, to prevent warning
NewBook.Sheets("Sheet1").Visible = False
NewBook.Sheets("Sheet2").Visible = False
NewBook.Sheets("Sheet3").Visible = False
'Folder picker dialog does not allow multiple selection (unlike
' file picker), so store each separate folder selection in array.
'Cancel button ends selection loop.
i = 0
Do
'Show Folder Picker dialog. Returns -1 if selection made, 0 if canceled
If fd.Show = 0 Then
Exit Do
Else
i = i + 1
ReDim Preserve sFolderName(i)
sFolderName(i) = fd.SelectedItems.Item(1)
Worksheets("Info").Cells(i, 1) = Mid$(sFolderName(i), InStrRev(sFolderName(i), "\") + 1)
End If
Loop
'If no folder selected, exit
If i = 0 Then GoTo exit_AP_With_Edge_Multi
'Disable screen update to speed up macro execution (restored to True at exit)
' (do after folder picker so selected folders are shown on Info sheet).
Application.ScreenUpdating = False
'Extract parent folder name from first selected folder to use as file name
iEndPos = InStrRev(sFolderName(1), "\") - 1
iStartPos = InStrRev(sFolderName(1), "\", iEndPos - 1) + 1
NewBook.Title = Mid$(sFolderName(1), iStartPos, iEndPos - iStartPos + 1)
'Create new sheet for file info
Set NewSheet = Worksheets.Add
NewSheet.Name = "All Aalv"
Set NewSheet = Worksheets.Add
NewSheet.Name = "All Asurf"
Set NewSheet = Worksheets.Add
NewSheet.Name = "All Aair%"
Set NewSheet = Worksheets.Add
NewSheet.Name = "All Atis%"
Set NewSheet = Worksheets.Add
NewSheet.Name = "All Atis"
Set fs = Application.FileSearch
iAllDataCol = 0
iAllStatsRow = 1
iAllStatsCol = UBound(sFolderName) + 3
iAllMeansCol = iAllStatsCol + 3
iAllMeansRow = 2
For Each vSelectedItem In sFolderName()
'Search for files in selected folder
With fs
.NewSearch
.LookIn = vSelectedItem
.SearchSubFolders = False
.fileName = "*_Aalv_e.txt" 'Handles Aalv and Aalve files
If .Execute > 0 Then
'Store found files filename (text after last "\") in array then sort
i = 0
For Each vFoundItem In .FoundFiles
i = i + 1
ReDim Preserve sFileName(i)
sFileName(i) = Mid$(vFoundItem, InStrRev(vFoundItem, "\") + 1)
Next
'If no files or valid filenames, exit
If i = 0 Then
MsgBox "No files to measure.", vbCritical, "Message"
GoTo exit_AP_With_Edge_Multi
End If
SelectionSortStrings sFileName
'Create new sheet
Set NewSheet = Worksheets.Add
NewSheet.Name = Mid$(vSelectedItem, InStrRev(vSelectedItem, "\") + 1)
iCol = 1
ReDim aRangeAalv(1)
ReDim aRangeAsur(1)
ReDim aRangeAair(1)
ReDim aRangeAtis(1)
iRangeCnt = LBound(aRangeAalv)
lMeasCnt = 0
'For each file in sorted array
For Each vFoundItem In sFileName()
'Extract selected file name from path for column label
iEndPos = InStrRev(vFoundItem, ".")
iStartPos = InStrRev(vFoundItem, "\", iEndPos - 1) + 1
'Include parent folder in group name
strColTitle = NewSheet.Name & "\" & Mid$(vFoundItem, iStartPos, iEndPos - iStartPos)
'strColTitle = Mid$(vFoundItem, iStartPos, iEndPos - iStartPos)
'Import corresponding Aair_roi file
sAirFileName = Mid$(vFoundItem, 1, InStrRev(vFoundItem, "Aalv_e")) + "air_roi.txt"
With ActiveSheet.QueryTables.Add(Connection:="TEXT;" & vSelectedItem & "\" & sAirFileName, _
Destination:=ActiveSheet.Cells(1, (iCol)))
.Refresh
End With
'Find last row
Columns(iCol).End(xlDown).Select
lEndRow = ActiveCell.Row
'Aair scaled to microns in next column
Cells(1, iCol + 1).FormulaR1C1 = "=+RC[-1]*" & cSqMicronsPerPixel
Cells(1, iCol + 1).Select
Selection.Copy
Range(Cells(2, iCol + 1), Cells(lEndRow, iCol + 1)).Select
ActiveSheet.Paste
'Copy Aroi cell value (last value in column) into destination cell
Cells(3, iCol + 3) = Cells(lEndRow, iCol + 1).Value
'Sum Air and enter into its cell
Cells(6, iCol + 3) = WorksheetFunction.Sum(Range(Cells(1, iCol + 1), Cells(lEndRow - 1, iCol + 1)))
'Set column title, width and number format
Cells(2, iCol + 3).Value = "Aroi (µm²)"
Cells(5, iCol + 3).Value = "Aair (µm²)"
Columns(iCol + 3).ColumnWidth = Len("Aroi (µm²)")
Columns(iCol + 3).NumberFormat = "0.0"
'Delete raw and scaled Aair columns.
Range(Cells(1, iCol), Cells(lEndRow, iCol + 1)).Select
Selection.ClearContents
'Import area and perimeter data (pixels)
'Import resets column widths so do first
With ActiveSheet.QueryTables.Add(Connection:="TEXT;" & vSelectedItem & "\" & vFoundItem, Destination:=ActiveSheet.Cells(3, (iCol)))
.Refresh
End With
'Column title and width
Cells(2, iCol).Value = "Aalv(px)"
Columns(iCol).ColumnWidth = Len("Aalv (px)")
'Asurf (pixels)
'Set column title
'(contiguous cells required to find last cell)
Cells(1, iCol + 1).Value = "."
Cells(2, iCol + 1).Value = "Asurf (px)"
'Find last row
Columns(iCol + 1).End(xlDown).Select
lEndRow = ActiveCell.Row
Cells(1, iCol + 1).Clear 'remove "."
'Move column over
Columns(iCol + 1).Select
Selection.Cut
ActiveSheet.Paste Columns(iCol + 6)
'Set column width and number format
'Columns(iCol + 6).ColumnWidth = Len("Asurf (px)")
'Range(Cells(3, iCol + 6), Cells(lEndRow - 1, iCol + 6)).NumberFormat = "0.0"
'Above commented because column will be overwritten
'Aalv scaled to microns
'lEndRow same as Asurf column
Cells(3, iCol + 1).FormulaR1C1 = "=+RC[-1]*" & cSqMicronsPerPixel
Cells(3, iCol + 1).Select
Selection.Copy
Range(Cells(4, iCol + 1), Cells(lEndRow, iCol + 1)).Select
ActiveSheet.Paste
'Overwrite raw data with scaled data, converting formulas to values
' (will not work with cut- use copy)
Range(Cells(2, iCol + 1), Cells(lEndRow, iCol + 1)).Select
Selection.Copy
Cells(2, iCol).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
'Delete source range
Range(Cells(2, iCol + 1), Cells(lEndRow, iCol + 1)).Select
Selection.ClearContents
'Set column title, width and number format
Cells(2, iCol).Value = "Aalv (µm²)"
Columns(iCol).ColumnWidth = Len("Aalv (µm²)")
Range(Cells(3, iCol), Cells(lEndRow, iCol)).NumberFormat = "0.0"
'If the total number of measurements exceeds Excel limit prompt and end macro.
'Although the imported column will contain fewer rows than the Excel limit,
'the Excel limit would be reached at the cut/paste into the All column stage.
'Quicker to prompt here.
lMeasCnt = lMeasCnt + Range(Cells(3, iCol), Cells(lEndRow, iCol)).Count
If lMeasCnt > 65536 Then
MsgBox "The total number of measurements has exceeded the Excel limit of 65536.", vbCritical
GoTo exit_AP_With_Edge_Multi
End If
'Aalv descriptive statistics (first row of range is column title)
Application.Run "ATPVBAEN.XLA!Descr", _
Range(Cells(2, iCol), Cells(lEndRow, iCol)), _
Cells(2, iCol + 1), "C", True, True
'Set column width
Columns(iCol + 1).ColumnWidth = 16
'Set number format except for count which remains an integer
Range(Cells(3, iCol + 2), Cells(15, iCol + 2)).NumberFormat = "0.0"
'Airspace percent (Aair/Aroi)
'Set column title, width and number format
Cells(2, iCol + 4).Value = "Aair (%)"
Columns(iCol + 4).ColumnWidth = Len("Aair (%)")
Cells(3, iCol + 4).NumberFormat = "0.0"
'Calculate value
'Cells(3, iCol + 4).FormulaR1C1 = "=SUM(C[-4])/(C[-1])*100"
'ActiveSheet.Calculate
Cells(3, iCol + 4) = (Cells(6, iCol + 3) / Cells(3, iCol + 3)) * 100
'Tissue area (Aroi - Aair)
'Set column title, width and number format
Cells(2, iCol + 5).Value = "Atis (µm²)"
Columns(iCol + 5).ColumnWidth = Len("Atis (µm²)")
Cells(3, iCol + 5).NumberFormat = "0.0"
'Calculate value
'Cells(3, iCol + 5).FormulaR1C1 = "=(C[-2])-SUM(C[-5])"
'ActiveSheet.Calculate
Cells(3, iCol + 5) = Cells(3, iCol + 3) - Cells(6, iCol + 3)
'Asurf scaled to microns (uses non-squared conversion factor because it is perimeter (length)
Cells(3, iCol + 7).FormulaR1C1 = "=+RC[-1]*" & cMicronsPerPixel
Cells(3, iCol + 7).Select
Selection.Copy
Range(Cells(4, iCol + 7), Cells(lEndRow, iCol + 7)).Select
ActiveSheet.Paste
'Overwrite raw data with scaled data, converting formulas to values
' (will not work with cut- use copy)
Range(Cells(2, iCol + 7), Cells(lEndRow, iCol + 7)).Select
Selection.Copy
Cells(2, iCol + 6).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
'Delete source range
Range(Cells(2, iCol + 7), Cells(lEndRow, iCol + 7)).Select
Selection.ClearContents
'Set column title, width and number format
Cells(2, iCol + 6).Value = "Asurf (µm)"
Columns(iCol + 6).ColumnWidth = Len("Asurf (µm)")
Range(Cells(3, iCol + 6), Cells(lEndRow, iCol + 6)).NumberFormat = "0.0"
'Asurf descriptive statistics (first row of range is column title)
Application.Run "ATPVBAEN.XLA!Descr", _
Range(Cells(2, iCol + 6), Cells(lEndRow, iCol + 6)), _
Cells(2, iCol + 7), "C", True, True
'Set column width
Columns(iCol + 7).ColumnWidth = 16
'Set number format for stats (limit range to keep Count a whole number)
Range(Cells(3, iCol + 8), Cells(15, iCol + 8)).NumberFormat = "0.0"
'Set blank column width
Columns(iCol + 9).ColumnWidth = 5
'Group title
'Done at end of loop because cells used for title need to have text
' added to make contiguous column for finding last cell. Once cells
' are merged to store title, cannot add text to B1 and could not find
' last cell in column.
'Range(Cells(1, iCol), Cells(1, iCol + 2)).Select
Cells(1, iCol).Select
With Selection
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = True
.Value = strColTitle
.Font.Bold = True
End With
'Store current range in array
ReDim Preserve aRangeAalv(UBound(aRangeAalv) + 1)
ReDim Preserve aRangeAsur(UBound(aRangeAsur) + 1)
ReDim Preserve aRangeAair(UBound(aRangeAair) + 1)
ReDim Preserve aRangeAtis(UBound(aRangeAtis) + 1)
Set aRangeAalv(iRangeCnt) = Range(Cells(3, iCol), Cells(lEndRow, iCol))
Set aRangeAsur(iRangeCnt) = Range(Cells(3, iCol + 6), Cells(lEndRow, iCol + 6))
Set aRangeAair(iRangeCnt) = Range(Cells(3, iCol + 4), Cells(3, iCol + 4))
Set aRangeAtis(iRangeCnt) = Range(Cells(3, iCol + 5), Cells(lEndRow, iCol + 5))
iRangeCnt = iRangeCnt + 1
iCol = iCol + 10
Next vFoundItem
'Truncate empty range elements
ReDim Preserve aRangeAalv(iRangeCnt - 1)
ReDim Preserve aRangeAsur(iRangeCnt - 1)
ReDim Preserve aRangeAair(iRangeCnt - 1)
ReDim Preserve aRangeAtis(iRangeCnt - 1)
'All Aalv column title and width
Cells(1, iCol).Value = "All Aalv"
Cells(1, iCol).Font.Bold = True
Cells(2, iCol).Value = "Aalv (µm²)"
Columns(iCol).ColumnWidth = Len("Aalv (µm²)")
'Paste each column into all column
For iRangeCnt = LBound(aRangeAalv) To UBound(aRangeAalv)
aRangeAalv(iRangeCnt).Select
'Selection.Copy
Selection.Cut
'Find last row of destination column
Columns(iCol).End(xlDown).Select
lEndRow = ActiveCell.Row
Cells(lEndRow + 1, iCol).Select
'Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
ActiveSheet.Paste
Next
'Find last row of destination column
Columns(iCol).End(xlDown).Select
lEndRow = ActiveCell.Row
'All column number format
Range(Cells(3, iCol), Cells(lEndRow, iCol)).NumberFormat = "0.0"
'All Aalv descriptive statistics
Application.Run "ATPVBAEN.XLA!Descr", _
Range(Cells(2, iCol), Cells(lEndRow, iCol)), _
Cells(2, iCol + 1), "C", True, True
Columns(iCol + 1).ColumnWidth = 16 'stats col width
'Set numberformat for stats (limit range to keep count a whole number)
Range(Cells(3, iCol + 2), Cells(15, iCol + 2)).NumberFormat = "0.0"
iCol = iCol + 4
'All Asurf column title and width
Cells(1, iCol).Value = "All Asurf"
Cells(1, iCol).Font.Bold = True
Cells(2, iCol).Value = "Asurf (µm)"
Columns(iCol).ColumnWidth = Len("Asurf (µm)")
'Paste each column into all column
For iRangeCnt = LBound(aRangeAsur) To UBound(aRangeAsur)
aRangeAsur(iRangeCnt).Select
'Selection.Copy
Selection.Cut
'Find last row of destination column
Columns(iCol).End(xlDown).Select
lEndRow = ActiveCell.Row
Cells(lEndRow + 1, iCol).Select
'Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
ActiveSheet.Paste
Next
'Find last row of destination column
Columns(iCol).End(xlDown).Select
lEndRow = ActiveCell.Row
'All column number format
Range(Cells(3, iCol), Cells(lEndRow, iCol)).NumberFormat = "0.0"
'All Asurf descriptive statistics
Application.Run "ATPVBAEN.XLA!Descr", _
Range(Cells(2, iCol), Cells(lEndRow, iCol)), _
Cells(2, iCol + 1), "C", True, True
Columns(iCol + 1).ColumnWidth = 16 'stats col width
'Set numberformat for stats (limit range to keep count a whole number)
Range(Cells(3, iCol + 2), Cells(15, iCol + 2)).NumberFormat = "0.0"
iCol = iCol + 4
'All Aair% column title and width
Cells(1, iCol).Value = "All Aair"
Cells(1, iCol).Font.Bold = True
Cells(2, iCol).Value = "Aair (%)"
Columns(iCol).ColumnWidth = Len("Aair (%)")
'Paste each column into all column
For iRangeCnt = LBound(aRangeAair) To UBound(aRangeAair)
aRangeAair(iRangeCnt).Select
Selection.Copy
'Find last row of destination column
Columns(iCol).End(xlDown).Select
lEndRow = ActiveCell.Row
Cells(lEndRow + 1, iCol).Select
'Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
ActiveSheet.Paste
Next
'Find last row of destination column
Columns(iCol).End(xlDown).Select
lEndRow = ActiveCell.Row
'All column number format
Range(Cells(3, iCol), Cells(lEndRow, iCol)).NumberFormat = "0.0"
'All Aair descriptive statistics
Application.Run "ATPVBAEN.XLA!Descr", _
Range(Cells(2, iCol), Cells(lEndRow, iCol)), _
Cells(2, iCol + 1), "C", True, True
Columns(iCol + 1).ColumnWidth = 16 'stats col width
'Set numberformat for stats (limit range to keep count a whole number)
Range(Cells(3, iCol + 2), Cells(15, iCol + 2)).NumberFormat = "0.0"
iCol = iCol + 4
'All Atis% column title and width
'Values are calculate from preceding Aair column
Cells(1, iCol).Value = "All Atis"
Cells(1, iCol).Font.Bold = True
Cells(2, iCol).Value = "Atis (%)"
Columns(iCol).ColumnWidth = Len("Atis (%)")
'Atis % = 100-Aair%
Cells(3, iCol).FormulaR1C1 = "=100-(+RC[-4])"
Cells(3, iCol).Select
Selection.Copy
Range(Cells(3, iCol), Cells(lEndRow, iCol)).Select 'Endrow from Aair column
ActiveSheet.Paste
'Convert formulas to values
Range(Cells(3, iCol), Cells(lEndRow, iCol)).Select
Selection.Copy
Cells(3, iCol).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
'All column number format
Range(Cells(3, iCol), Cells(lEndRow, iCol)).NumberFormat = "0.0"
'All Aair descriptive statistics
Application.Run "ATPVBAEN.XLA!Descr", _
Range(Cells(2, iCol), Cells(lEndRow, iCol)), _
Cells(2, iCol + 1), "C", True, True
Columns(iCol + 1).ColumnWidth = 16 'stats col width
'Set numberformat for stats (limit range to keep count a whole number)
Range(Cells(3, iCol + 2), Cells(15, iCol + 2)).NumberFormat = "0.0"
iCol = iCol + 4
'All Atis column title and width
Cells(1, iCol).Value = "All Atis"
Cells(1, iCol).Font.Bold = True
Cells(2, iCol).Value = "Atis (µm²)"
Columns(iCol).ColumnWidth = Len("Atis (µm²)")
'Paste each column into all column
For iRangeCnt = LBound(aRangeAtis) To UBound(aRangeAtis)
aRangeAtis(iRangeCnt).Select
Selection.Copy
'Find last row of destination column
Columns(iCol).End(xlDown).Select
lEndRow = ActiveCell.Row
Cells(lEndRow + 1, iCol).Select
'Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
ActiveSheet.Paste
Next
'Find last row of destination column
Columns(iCol).End(xlDown).Select
lEndRow = ActiveCell.Row
'All column number format
Range(Cells(3, iCol), Cells(lEndRow, iCol)).NumberFormat = "0.0"
'All Atis descriptive statistics
Application.Run "ATPVBAEN.XLA!Descr", _
Range(Cells(2, iCol), Cells(lEndRow, iCol)), _
Cells(2, iCol + 1), "C", True, True
Columns(iCol + 1).ColumnWidth = 16 'stats col width
'Set numberformat for stats (limit range to keep count a whole number)
Range(Cells(3, iCol + 2), Cells(15, iCol + 2)).NumberFormat = "0.0"
CenterColTitles
PageSetup
iAllDataCol = iAllDataCol + 1
'Move All Aalv data to Aalv sheet
'NewSheet.Name still refers to data sheet since it was the last sheet created
Worksheets(NewSheet.Name).Activate 'select data sheet
iCol = iCol - 16
Columns(iCol).End(xlDown).Select 'Find last row
lEndRow = ActiveCell.Row
Range(Cells(3, iCol), Cells(lEndRow, iCol)).Select
Selection.Cut
Worksheets("All Aalv").Activate
Cells(2, iAllDataCol).Select
ActiveSheet.Paste
'Reserve row 1 for titles
Cells(1, iAllDataCol).Font.Bold = True
Cells(1, iAllDataCol).Value = NewSheet.Name
'Move All stats to All sheet
'NewSheet.Name still refers to data sheet since it was the last sheet created
Worksheets(NewSheet.Name).Activate
Range(Cells(2, iCol + 1), Cells(16, iCol + 2)).Select
Selection.Copy
Cells(1, 1).Select 'Reset data sheet position
Worksheets("All Aalv").Activate
Cells(iAllStatsRow + 1, iAllStatsCol).Select
ActiveSheet.Paste
Columns(iAllStatsCol).ColumnWidth = 16 'stats col width
Columns(iAllStatsCol + 1).ColumnWidth = 12
'Group title
Cells(iAllStatsRow, iAllStatsCol).Select
With Selection
.Value = NewSheet.Name & " (All)"
.Font.Bold = True
End With
'Copy mean value into All Means column
'Group title
Cells(1, iAllMeansCol).Value = "All Means"
Cells(1, iAllMeansCol).Font.Bold = True
'Copy group stats mean into All Means column
Cells(iAllStatsRow + 3, iAllStatsCol + 1).Select
Selection.Copy
Cells(iAllMeansRow, iAllMeansCol).Select
ActiveSheet.Paste
Cells(1, 1).Select 'Reset all sheet position
'Move All Asurf column to Asurf sheet
Worksheets(NewSheet.Name).Activate 'select data sheet
iCol = iCol + 4
Columns(iCol).End(xlDown).Select 'Find last row
lEndRow = ActiveCell.Row
Range(Cells(3, iCol), Cells(lEndRow, iCol)).Select
Selection.Cut
Worksheets("All Asurf").Activate
Cells(2, iAllDataCol).Select
ActiveSheet.Paste
'Reserve row 1 for titles
Cells(1, iAllDataCol).Font.Bold = True
Cells(1, iAllDataCol).Value = NewSheet.Name
'Move All stats to All sheet
'NewSheet.Name still refers to data sheet since it was the last sheet created
Worksheets(NewSheet.Name).Activate
Range(Cells(2, iCol + 1), Cells(16, iCol + 2)).Select
Selection.Copy
Cells(1, 1).Select 'Reset data sheet position
Worksheets("All Asurf").Activate
Cells(iAllStatsRow + 1, iAllStatsCol).Select
ActiveSheet.Paste
Columns(iAllStatsCol).ColumnWidth = 16 'stats col width
Columns(iAllStatsCol + 1).ColumnWidth = 12
'Group title
Cells(iAllStatsRow, iAllStatsCol).Select
With Selection
.Value = NewSheet.Name & " (All)"
.Font.Bold = True
End With
'Copy mean value into All Means column
'Group title
Cells(1, iAllMeansCol).Value = "All Means"
Cells(1, iAllMeansCol).Font.Bold = True
'Copy group stats mean into All Means column
Cells(iAllStatsRow + 3, iAllStatsCol + 1).Select
Selection.Copy
Cells(iAllMeansRow, iAllMeansCol).Select
ActiveSheet.Paste
Cells(1, 1).Select 'Reset all sheet position
'Move All Aair column to Aair sheet
Worksheets(NewSheet.Name).Activate 'select data sheet
iCol = iCol + 4
Columns(iCol).End(xlDown).Select 'Find last row
lEndRow = ActiveCell.Row
Range(Cells(3, iCol), Cells(lEndRow, iCol)).Select
Selection.Cut
Worksheets("All Aair%").Activate
Cells(2, iAllDataCol).Select
ActiveSheet.Paste
'Reserve row 1 for titles
Cells(1, iAllDataCol).Font.Bold = True
Cells(1, iAllDataCol).Value = NewSheet.Name
'Move All stats to All sheet
'NewSheet.Name still refers to data sheet since it was the last sheet created
Worksheets(NewSheet.Name).Activate
Range(Cells(2, iCol + 1), Cells(16, iCol + 2)).Select
Selection.Copy
Cells(1, 1).Select 'Reset data sheet position
Worksheets("All Aair%").Activate
Cells(iAllStatsRow + 1, iAllStatsCol).Select
ActiveSheet.Paste
Columns(iAllStatsCol).ColumnWidth = 16 'stats col width
Columns(iAllStatsCol + 1).ColumnWidth = 12
'Group title
Cells(iAllStatsRow, iAllStatsCol).Select
With Selection
.Value = NewSheet.Name & " (All)"
.Font.Bold = True
End With
'Copy mean value into All Means column
'Group title
Cells(1, iAllMeansCol).Value = "All Means"
Cells(1, iAllMeansCol).Font.Bold = True
'Copy group stats mean into All Means column
Cells(iAllStatsRow + 3, iAllStatsCol + 1).Select
Selection.Copy
Cells(iAllMeansRow, iAllMeansCol).Select
ActiveSheet.Paste
Cells(1, 1).Select 'Reset all sheet position
'Move All Atis% column to Atis% sheet
Worksheets(NewSheet.Name).Activate 'select data sheet
iCol = iCol + 4
Columns(iCol).End(xlDown).Select 'Find last row
lEndRow = ActiveCell.Row
Range(Cells(3, iCol), Cells(lEndRow, iCol)).Select
Selection.Cut
Worksheets("All Atis%").Activate
Cells(2, iAllDataCol).Select
ActiveSheet.Paste
'Reserve row 1 for titles
Cells(1, iAllDataCol).Font.Bold = True
Cells(1, iAllDataCol).Value = NewSheet.Name
'Move All stats to All sheet
'NewSheet.Name still refers to data sheet since it was the last sheet created
Worksheets(NewSheet.Name).Activate
Range(Cells(2, iCol + 1), Cells(16, iCol + 2)).Select
Selection.Copy
Cells(1, 1).Select 'Reset data sheet position
Worksheets("All Atis%").Activate
Cells(iAllStatsRow + 1, iAllStatsCol).Select
ActiveSheet.Paste
Columns(iAllStatsCol).ColumnWidth = 16 'stats col width
Columns(iAllStatsCol + 1).ColumnWidth = 12
'Group title
Cells(iAllStatsRow, iAllStatsCol).Select
With Selection
.Value = NewSheet.Name & " (All)"
.Font.Bold = True
End With
'Copy mean value into All Means column
'Group title
Cells(1, iAllMeansCol).Value = "All Means"
Cells(1, iAllMeansCol).Font.Bold = True
'Copy group stats mean into All Means column
Cells(iAllStatsRow + 3, iAllStatsCol + 1).Select
Selection.Copy
Cells(iAllMeansRow, iAllMeansCol).Select
ActiveSheet.Paste
Cells(1, 1).Select 'Reset all sheet position
'Move All Atis column to Atis sheet
Worksheets(NewSheet.Name).Activate 'select data sheet
iCol = iCol + 4
Columns(iCol).End(xlDown).Select 'Find last row
lEndRow = ActiveCell.Row
Range(Cells(3, iCol), Cells(lEndRow, iCol)).Select
Selection.Cut
Cells(1, 1).Select 'Reset data sheet position
Worksheets("All Atis").Activate
Cells(2, iAllDataCol).Select
ActiveSheet.Paste
'Reserve row 1 for titles
Cells(1, iAllDataCol).Font.Bold = True
Cells(1, iAllDataCol).Value = NewSheet.Name
'Move All stats to All sheet
'NewSheet.Name still refers to data sheet since it was the last sheet created
Worksheets(NewSheet.Name).Activate
Range(Cells(2, iCol + 1), Cells(16, iCol + 2)).Select
Selection.Copy
Cells(1, 1).Select 'Reset data sheet position
Worksheets("All Atis").Activate
Cells(iAllStatsRow + 1, iAllStatsCol).Select
ActiveSheet.Paste
Columns(iAllStatsCol).ColumnWidth = 16 'stats col width
Columns(iAllStatsCol + 1).ColumnWidth = 12
'Group title
Cells(iAllStatsRow, iAllStatsCol).Select
With Selection
.Value = NewSheet.Name & " (All)"
.Font.Bold = True
End With
'Copy mean value into All Means column
'Group title
Cells(1, iAllMeansCol).Value = "All Means"
Cells(1, iAllMeansCol).Font.Bold = True
'Copy group stats mean into All Means column
Cells(iAllStatsRow + 3, iAllStatsCol + 1).Select
Selection.Copy
Cells(iAllMeansRow, iAllMeansCol).Select
ActiveSheet.Paste
Cells(1, 1).Select 'Reset all sheet position
iAllMeansRow = iAllMeansRow + 1
iAllStatsRow = iAllStatsRow + 17
Else
MsgBox "No files found in folder " & vSelectedItem, vbExclamation, "Message"
End If
End With
Next vSelectedItem
'-------All means
Worksheets("All Aalv").Activate
iCol = iAllMeansCol
'Find last row of destination column
Columns(iCol).End(xlDown).Select
lEndRow = ActiveCell.Row
'All column number format
Range(Cells(1, iCol), Cells(lEndRow, iCol)).NumberFormat = "0.0"
'Descriptive statistics
'Descr function: input range, output range, grouped, labels, summary, ds_large, ds_small, confidence
'Grouped="C" for columns, "R" for rows
Application.Run "ATPVBAEN.XLA!Descr", _
Range(Cells(1, iCol), Cells(lEndRow, iCol)), _
Cells(1, iCol + 1), "C", True, True
Columns(iCol + 1).ColumnWidth = 16 'stats col width
'Stats column title
Cells(1, iCol + 1).Value = "Aalv (µm²)"
'Columns(iCol + 1).ColumnWidth = Len("Aalv (µm²)")
'Set numberformat for stats (limit range to keep count a whole number)
Range(Cells(3, iCol + 2), Cells(14, iCol + 2)).NumberFormat = "0.0"
'All means
Worksheets("All Asurf").Activate
iCol = iAllMeansCol
'Find last row of destination column
Columns(iCol).End(xlDown).Select
lEndRow = ActiveCell.Row
'All column number format
Range(Cells(1, iCol), Cells(lEndRow, iCol)).NumberFormat = "0.0"
'Descriptive statistics
Application.Run "ATPVBAEN.XLA!Descr", _
Range(Cells(1, iCol), Cells(lEndRow, iCol)), _
Cells(1, iCol + 1), "C", True, True
Columns(iCol + 1).ColumnWidth = 16 'stats col width
'Stats column title
Cells(1, iCol + 1).Value = "Asurf (µm)"
'Columns(iCol + 1).ColumnWidth = Len("Asurf (µm)")
'Set numberformat for stats (limit range to keep count a whole number)
Range(Cells(3, iCol + 2), Cells(14, iCol + 2)).NumberFormat = "0.0"
'All means
Worksheets("All Aair%").Activate
iCol = iAllMeansCol
'Find last row of destination column
Columns(iCol).End(xlDown).Select
lEndRow = ActiveCell.Row
'All column number format
Range(Cells(1, iCol), Cells(lEndRow, iCol)).NumberFormat = "0.0"
'Descriptive statistics
Application.Run "ATPVBAEN.XLA!Descr", _
Range(Cells(1, iCol), Cells(lEndRow, iCol)), _
Cells(1, iCol + 1), "C", True, True
Columns(iCol + 1).ColumnWidth = 16 'stats col width
'Stats column title
Cells(1, iCol + 1).Value = "Aair (%)"
'Columns(iCol + 1).ColumnWidth = Len("Aair (%)")
'Set numberformat for stats (limit range to keep count a whole number)
Range(Cells(3, iCol + 2), Cells(14, iCol + 2)).NumberFormat = "0.0"
'All means
Worksheets("All Atis%").Activate
iCol = iAllMeansCol
'Find last row of destination column
Columns(iCol).End(xlDown).Select
lEndRow = ActiveCell.Row
'All column number format
Range(Cells(1, iCol), Cells(lEndRow, iCol)).NumberFormat = "0.0"
'Descriptive statistics
Application.Run "ATPVBAEN.XLA!Descr", _
Range(Cells(1, iCol), Cells(lEndRow, iCol)), _
Cells(1, iCol + 1), "C", True, True
Columns(iCol + 1).ColumnWidth = 16 'stats col width
'Stats column title
Cells(1, iCol + 1).Value = "Atis (%)"
'Columns(iCol + 1).ColumnWidth = Len("Atis (%)")
'Set numberformat for stats (limit range to keep count a whole number)
Range(Cells(3, iCol + 2), Cells(14, iCol + 2)).NumberFormat = "0.0"
'All means
Worksheets("All Atis").Activate
iCol = iAllMeansCol
'Find last row of destination column
Columns(iCol).End(xlDown).Select
lEndRow = ActiveCell.Row
'All column number format
Range(Cells(1, iCol), Cells(lEndRow, iCol)).NumberFormat = "0.0"
'Descriptive statistics
Application.Run "ATPVBAEN.XLA!Descr", _
Range(Cells(1, iCol), Cells(lEndRow, iCol)), _
Cells(1, iCol + 1), "C", True, True
Columns(iCol + 1).ColumnWidth = 16 'stats col width
'Stats column title
Cells(1, iCol + 1).Value = "Atis (µm²)"
'Columns(iCol + 1).ColumnWidth = Len("Atis (µm²)")
'Set numberformat for stats (limit range to keep count a whole number)
Range(Cells(3, iCol + 2), Cells(14, iCol + 2)).NumberFormat = "0.0"
'-------- end of All means
'Set object variables to Nothing.
Set fd = Nothing
Set fs = Nothing
'Save workbook
sFileSaveName = Application.GetSaveAsFilename(NewBook.Title & "_Ae.xls", "Excel Files (*.xls), *.xls")
If sFileSaveName <> "False" Then
On Error Resume Next 'ignore rte 1004 if No reply to overwrite
NewBook.SaveAs sFileSaveName
'NewBook.SaveAs fileName:=NewBook.Title & "_A.xls"
On Error GoTo err_AP_With_Edge_Multi
End If
exit_AP_With_Edge_Multi:
Application.ScreenUpdating = True
Exit Sub
err_AP_With_Edge_Multi:
'If same folder chosen (only when testing) increment the sheet name to prevent duplicate sheet error.
If Left(Err.Description, 55) = "Cannot rename a sheet to the same name as another sheet" Then
NewSheet.Name = Mid$(vSelectedItem, InStrRev(vSelectedItem, "\") + 1) & " Copy" & iDupCnt
iDupCnt = iDupCnt + 1
Resume Next
Else
MsgBox Err.Description
Resume exit_AP_With_Edge_Multi
End If
End Sub
Sub AP_No_Edge_Multi()
'Open folderpicker filedialog box
'For each selected folder:
'For each area/perimeter (*_Aalv.TXT) file in the selected folder:
'Display data
'Display descriptive statistics in adjacent columns
'Move data from each column into 'All' column and display descriptive stats
'Move 'All' column into separate sheets: Aalv, Asurf, Aair, Atis%, Atis
On Error GoTo err_AP_No_Edge_Multi
Dim NewBook As Workbook
Dim NewSheet As Worksheet
Dim fd As FileDialog 'file/folder picker dialog
Dim vSelectedItem As Variant 'contains selected file path- variant required for For Each...Next
Dim fs As FileSearch 'used with file searches-returns founditems
Dim vFoundItem As Variant 'contains file paths found in vSelectedItem
Dim sFolderName() As String 'folder names array
Dim sFileName() As String 'file names array
Dim sAirFileName As String
Dim sFileSaveName As String 'workbook save name
Dim iFileNum As Integer
Dim iFileNumMax As Integer
Dim iDupCnt As Integer 'Counter for handling duplicate sheet name error
Dim i As Integer 'loop counter
Dim iCol As Integer
Dim lEndRow As Long
Dim iAllStatsRow, iAllDataCol, iAllStatsCol, iAllMeansRow, iAllMeansCol As Integer ''All' sheet position
Dim iStartPos, iEndPos As Integer 'string parsing
Dim strColTitle As String
Dim aRangeAalv() As Range 'Array of ranges for Aalv
Dim aRangeAsur() As Range 'Array of ranges for Asurf
Dim aRangeAair() As Range 'Array of ranges for Aair
Dim aRangeAtis() As Range 'Array of ranges for Atis
Dim iRangeCnt As Integer 'Range array index
Dim lMeasCnt As Long 'Running total nr of measurements to prevent exceeding Excel row limit of 65536.
'Load Analysis Toolpak if it is not currently loaded...
'The password to access function definintions is: Wildebeest
If fAddInLoaded("Analysis ToolPak - VBA") = -1 Then
' Error finding Analysis Toolpak...
MsgBox "Analysis ToolPak Not Found", vbExclamation
GoTo exit_AP_No_Edge_Multi
End If
Set fd = Application.FileDialog(msoFileDialogFolderPicker)
'Add unnamed new workbook
Set NewBook = Workbooks.Add
'Create new sheet for file info
Set NewSheet = Worksheets.Add
NewSheet.Name = "Info"
iDupCnt = 1
'Hide default sheets instead of deleting, to prevent warning
NewBook.Sheets("Sheet1").Visible = False
NewBook.Sheets("Sheet2").Visible = False
NewBook.Sheets("Sheet3").Visible = False
'Folder picker dialog does not allow multiple selection (unlike
' file picker), so store each separate folder selection in array.
'Cancel button ends selection loop.
i = 0
Do
'Show Folder Picker dialog. Returns -1 if selection made, 0 if canceled
If fd.Show = 0 Then
Exit Do
Else
i = i + 1
ReDim Preserve sFolderName(i)
sFolderName(i) = fd.SelectedItems.Item(1)
Worksheets("Info").Cells(i, 1) = Mid$(sFolderName(i), InStrRev(sFolderName(i), "\") + 1)
End If
Loop
'If no folder selected, exit
If i = 0 Then GoTo exit_AP_No_Edge_Multi
'Disable screen update to speed up macro execution (restored to True at exit)
' (do after folder picker so selected folders are shown on Info sheet).
Application.ScreenUpdating = False
'Extract parent folder name from first selected folder to use as file name
iEndPos = InStrRev(sFolderName(1), "\") - 1
iStartPos = InStrRev(sFolderName(1), "\", iEndPos - 1) + 1
NewBook.Title = Mid$(sFolderName(1), iStartPos, iEndPos - iStartPos + 1)
'Create new sheet for file info
Set NewSheet = Worksheets.Add
NewSheet.Name = "All Aalv"
Set NewSheet = Worksheets.Add
NewSheet.Name = "All Asurf"
Set NewSheet = Worksheets.Add
NewSheet.Name = "All Aair%"
Set NewSheet = Worksheets.Add
NewSheet.Name = "All Atis%"
Set NewSheet = Worksheets.Add
NewSheet.Name = "All Atis"
Set fs = Application.FileSearch
iAllDataCol = 0
iAllStatsRow = 1
iAllStatsCol = UBound(sFolderName) + 3
iAllMeansCol = iAllStatsCol + 3
iAllMeansRow = 2
For Each vSelectedItem In sFolderName()
'Search for files in selected folder
With fs
.NewSearch
.LookIn = vSelectedItem
.SearchSubFolders = False
.fileName = "*_Aalv.txt" 'Handles Aalv and Aalve files
If .Execute > 0 Then
'Store found files filename (text after last "\") in array then sort
i = 0
For Each vFoundItem In .FoundFiles
i = i + 1
ReDim Preserve sFileName(i)
sFileName(i) = Mid$(vFoundItem, InStrRev(vFoundItem, "\") + 1)
Next
'If no files or valid filenames, exit
If i = 0 Then
MsgBox "No files to measure.", vbCritical, "Message"
GoTo exit_AP_No_Edge_Multi
End If
SelectionSortStrings sFileName
'Create new sheet
Set NewSheet = Worksheets.Add
NewSheet.Name = Mid$(vSelectedItem, InStrRev(vSelectedItem, "\") + 1)
iCol = 1
ReDim aRangeAalv(1)
ReDim aRangeAsur(1)
ReDim aRangeAair(1)
ReDim aRangeAtis(1)
iRangeCnt = LBound(aRangeAalv)
lMeasCnt = 0
'For each file in sorted array
For Each vFoundItem In sFileName()
'Extract selected file name from path for column label
iEndPos = InStrRev(vFoundItem, ".")
iStartPos = InStrRev(vFoundItem, "\", iEndPos - 1) + 1
'Include parent folder in group name
strColTitle = NewSheet.Name & "\" & Mid$(vFoundItem, iStartPos, iEndPos - iStartPos)
'strColTitle = Mid$(vFoundItem, iStartPos, iEndPos - iStartPos)
'Import corresponding Aair_roi file
sAirFileName = Mid$(vFoundItem, 1, InStrRev(vFoundItem, "Aalv")) + "air_roi.txt"
With ActiveSheet.QueryTables.Add(Connection:="TEXT;" & vSelectedItem & "\" & sAirFileName, _
Destination:=ActiveSheet.Cells(1, (iCol)))
.Refresh
End With
'Find last row
Columns(iCol).End(xlDown).Select
lEndRow = ActiveCell.Row
'Aair scaled to microns in next column
Cells(1, iCol + 1).FormulaR1C1 = "=+RC[-1]*" & cSqMicronsPerPixel
Cells(1, iCol + 1).Select
Selection.Copy
Range(Cells(2, iCol + 1), Cells(lEndRow, iCol + 1)).Select
ActiveSheet.Paste
'Copy Aroi cell value (last value in column) into destination cell
Cells(3, iCol + 3) = Cells(lEndRow, iCol + 1).Value
'Sum Air and enter into its cell
Cells(6, iCol + 3) = WorksheetFunction.Sum(Range(Cells(1, iCol + 1), Cells(lEndRow - 1, iCol + 1)))
'Set column title, width and number format
Cells(2, iCol + 3).Value = "Aroi (µm²)"
Cells(5, iCol + 3).Value = "Aair (µm²)"
Columns(iCol + 3).ColumnWidth = Len("Aroi (µm²)")
Columns(iCol + 3).NumberFormat = "0.0"
'Delete raw and scaled Aair columns.
Range(Cells(1, iCol), Cells(lEndRow, iCol + 1)).Select
Selection.ClearContents
'Import area and perimeter data (pixels)
'Import resets column widths so do first
With ActiveSheet.QueryTables.Add(Connection:="TEXT;" & vSelectedItem & "\" & vFoundItem, Destination:=ActiveSheet.Cells(3, (iCol)))
.Refresh
End With
'Column title and width
Cells(2, iCol).Value = "Aalv(px)"
Columns(iCol).ColumnWidth = Len("Aalv (px)")
'Asurf (pixels)
'Set column title
'(contiguous cells required to find last cell)
Cells(1, iCol + 1).Value = "."
Cells(2, iCol + 1).Value = "Asurf (px)"
'Find last row
Columns(iCol + 1).End(xlDown).Select
lEndRow = ActiveCell.Row
Cells(1, iCol + 1).Clear 'remove "."
'Move column over
Columns(iCol + 1).Select
Selection.Cut
ActiveSheet.Paste Columns(iCol + 6)
'Set column width and number format
'Columns(iCol + 6).ColumnWidth = Len("Asurf (px)")
'Range(Cells(3, iCol + 6), Cells(lEndRow - 1, iCol + 6)).NumberFormat = "0.0"
'Above commented because column will be overwritten
'Aalv scaled to microns
'lEndRow same as Asurf column
Cells(3, iCol + 1).FormulaR1C1 = "=+RC[-1]*" & cSqMicronsPerPixel
Cells(3, iCol + 1).Select
Selection.Copy
Range(Cells(4, iCol + 1), Cells(lEndRow, iCol + 1)).Select
ActiveSheet.Paste
'Overwrite raw data with scaled data, converting formulas to values
' (will not work with cut- use copy)
Range(Cells(2, iCol + 1), Cells(lEndRow, iCol + 1)).Select
Selection.Copy
Cells(2, iCol).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
'Delete source range
Range(Cells(2, iCol + 1), Cells(lEndRow, iCol + 1)).Select
Selection.ClearContents
'Set column title, width and number format
Cells(2, iCol).Value = "Aalv (µm²)"
Columns(iCol).ColumnWidth = Len("Aalv (µm²)")
Range(Cells(3, iCol), Cells(lEndRow, iCol)).NumberFormat = "0.0"
'If the total number of measurements exceeds Excel limit prompt and end macro.
'Although the imported column will contain fewer rows than the Excel limit,
'the Excel limit would be reached at the cut/paste into the All column stage.
'Quicker to prompt here.
lMeasCnt = lMeasCnt + Range(Cells(3, iCol), Cells(lEndRow, iCol)).Count
If lMeasCnt > 65536 Then
MsgBox "The total number of measurements has exceeded the Excel limit of 65536.", vbCritical
GoTo exit_AP_No_Edge_Multi
End If
'Aalv descriptive statistics (first row of range is column title)
Application.Run "ATPVBAEN.XLA!Descr", _
Range(Cells(2, iCol), Cells(lEndRow, iCol)), _
Cells(2, iCol + 1), "C", True, True
'Set column width
Columns(iCol + 1).ColumnWidth = 16
'Set number format except for count which remains an integer
Range(Cells(3, iCol + 2), Cells(15, iCol + 2)).NumberFormat = "0.0"
'Airspace percent (Aair/Aroi)
'Set column title, width and number format
Cells(2, iCol + 4).Value = "Aair (%)"
Columns(iCol + 4).ColumnWidth = Len("Aair (%)")
Cells(3, iCol + 4).NumberFormat = "0.0"
'Calculate value
'Cells(3, iCol + 4).FormulaR1C1 = "=SUM(C[-4])/(C[-1])*100"
'ActiveSheet.Calculate
Cells(3, iCol + 4) = (Cells(6, iCol + 3) / Cells(3, iCol + 3)) * 100
'Tissue area (Aroi - Aair)
'Set column title, width and number format
Cells(2, iCol + 5).Value = "Atis (µm²)"
Columns(iCol + 5).ColumnWidth = Len("Atis (µm²)")
Cells(3, iCol + 5).NumberFormat = "0.0"
'Calculate value
'Cells(3, iCol + 5).FormulaR1C1 = "=(C[-2])-SUM(C[-5])"
'ActiveSheet.Calculate
Cells(3, iCol + 5) = Cells(3, iCol + 3) - Cells(6, iCol + 3)
'Asurf scaled to microns (uses non-squared conversion factor because it is perimeter (length)
Cells(3, iCol + 7).FormulaR1C1 = "=+RC[-1]*" & cMicronsPerPixel
Cells(3, iCol + 7).Select
Selection.Copy
Range(Cells(4, iCol + 7), Cells(lEndRow, iCol + 7)).Select
ActiveSheet.Paste
'Overwrite raw data with scaled data, converting formulas to values
' (will not work with cut- use copy)
Range(Cells(2, iCol + 7), Cells(lEndRow, iCol + 7)).Select
Selection.Copy
Cells(2, iCol + 6).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
'Delete source range
Range(Cells(2, iCol + 7), Cells(lEndRow, iCol + 7)).Select
Selection.ClearContents
'Set column title, width and number format
Cells(2, iCol + 6).Value = "Asurf (µm)"
Columns(iCol + 6).ColumnWidth = Len("Asurf (µm)")
Range(Cells(3, iCol + 6), Cells(lEndRow, iCol + 6)).NumberFormat = "0.0"
'Asurf descriptive statistics (first row of range is column title)
Application.Run "ATPVBAEN.XLA!Descr", _
Range(Cells(2, iCol + 6), Cells(lEndRow, iCol + 6)), _
Cells(2, iCol + 7), "C", True, True
'Set column width
Columns(iCol + 7).ColumnWidth = 16
'Set number format for stats (limit range to keep Count a whole number)
Range(Cells(3, iCol + 8), Cells(15, iCol + 8)).NumberFormat = "0.0"
'Set blank column width
Columns(iCol + 9).ColumnWidth = 5
'Group title
'Done at end of loop because cells used for title need to have text
' added to make contiguous column for finding last cell. Once cells
' are merged to store title, cannot add text to B1 and could not find
' last cell in column.
'Range(Cells(1, iCol), Cells(1, iCol + 2)).Select
Cells(1, iCol).Select
With Selection
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = True
.Value = strColTitle
.Font.Bold = True
End With
'Store current range in array
ReDim Preserve aRangeAalv(UBound(aRangeAalv) + 1)
ReDim Preserve aRangeAsur(UBound(aRangeAsur) + 1)
ReDim Preserve aRangeAair(UBound(aRangeAair) + 1)
ReDim Preserve aRangeAtis(UBound(aRangeAtis) + 1)
Set aRangeAalv(iRangeCnt) = Range(Cells(3, iCol), Cells(lEndRow, iCol))
Set aRangeAsur(iRangeCnt) = Range(Cells(3, iCol + 6), Cells(lEndRow, iCol + 6))
Set aRangeAair(iRangeCnt) = Range(Cells(3, iCol + 4), Cells(3, iCol + 4))
Set aRangeAtis(iRangeCnt) = Range(Cells(3, iCol + 5), Cells(lEndRow, iCol + 5))
iRangeCnt = iRangeCnt + 1
iCol = iCol + 10
Next vFoundItem
'Truncate empty range elements
ReDim Preserve aRangeAalv(iRangeCnt - 1)
ReDim Preserve aRangeAsur(iRangeCnt - 1)
ReDim Preserve aRangeAair(iRangeCnt - 1)
ReDim Preserve aRangeAtis(iRangeCnt - 1)
'All Aalv column title and width
Cells(1, iCol).Value = "All Aalv"
Cells(1, iCol).Font.Bold = True
Cells(2, iCol).Value = "Aalv (µm²)"
Columns(iCol).ColumnWidth = Len("Aalv (µm²)")
'Paste each column into all column
For iRangeCnt = LBound(aRangeAalv) To UBound(aRangeAalv)
aRangeAalv(iRangeCnt).Select
'Selection.Copy
Selection.Cut
'Find last row of destination column
Columns(iCol).End(xlDown).Select
lEndRow = ActiveCell.Row
Cells(lEndRow + 1, iCol).Select
'Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
ActiveSheet.Paste
Next
'Find last row of destination column
Columns(iCol).End(xlDown).Select
lEndRow = ActiveCell.Row
'All column number format
Range(Cells(3, iCol), Cells(lEndRow, iCol)).NumberFormat = "0.0"
'All Aalv descriptive statistics
Application.Run "ATPVBAEN.XLA!Descr", _
Range(Cells(2, iCol), Cells(lEndRow, iCol)), _
Cells(2, iCol + 1), "C", True, True
Columns(iCol + 1).ColumnWidth = 16 'stats col width
'Set numberformat for stats (limit range to keep count a whole number)
Range(Cells(3, iCol + 2), Cells(15, iCol + 2)).NumberFormat = "0.0"
'All Asurf column title and width
iCol = iCol + 4
Cells(1, iCol).Value = "All Asurf"
Cells(1, iCol).Font.Bold = True
Cells(2, iCol).Value = "Asurf (µm)"
Columns(iCol).ColumnWidth = Len("Asurf (µm)")
'Paste each column into all column
For iRangeCnt = LBound(aRangeAsur) To UBound(aRangeAsur)
aRangeAsur(iRangeCnt).Select
'Selection.Copy
Selection.Cut
'Find last row of destination column
Columns(iCol).End(xlDown).Select
lEndRow = ActiveCell.Row
Cells(lEndRow + 1, iCol).Select
'Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
ActiveSheet.Paste
Next
'Find last row of destination column
Columns(iCol).End(xlDown).Select
lEndRow = ActiveCell.Row
'All column number format
Range(Cells(3, iCol), Cells(lEndRow, iCol)).NumberFormat = "0.0"
'All Asurf descriptive statistics
Application.Run "ATPVBAEN.XLA!Descr", _
Range(Cells(2, iCol), Cells(lEndRow, iCol)), _
Cells(2, iCol + 1), "C", True, True
Columns(iCol + 1).ColumnWidth = 16 'stats col width
'Set numberformat for stats (limit range to keep count a whole number)
Range(Cells(3, iCol + 2), Cells(15, iCol + 2)).NumberFormat = "0.0"
'All Aair% column title and width
iCol = iCol + 4
Cells(1, iCol).Value = "All Aair"
Cells(1, iCol).Font.Bold = True
Cells(2, iCol).Value = "Aair (%)"
Columns(iCol).ColumnWidth = Len("Aair (%)")
'Paste each column into all column
For iRangeCnt = LBound(aRangeAair) To UBound(aRangeAair)
aRangeAair(iRangeCnt).Select
Selection.Copy
'Find last row of destination column
Columns(iCol).End(xlDown).Select
lEndRow = ActiveCell.Row
Cells(lEndRow + 1, iCol).Select
'Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
ActiveSheet.Paste
Next
'Find last row of destination column
Columns(iCol).End(xlDown).Select
lEndRow = ActiveCell.Row
'All column number format
Range(Cells(3, iCol), Cells(lEndRow, iCol)).NumberFormat = "0.0"
'All Aair descriptive statistics
Application.Run "ATPVBAEN.XLA!Descr", _
Range(Cells(2, iCol), Cells(lEndRow, iCol)), _
Cells(2, iCol + 1), "C", True, True
Columns(iCol + 1).ColumnWidth = 16 'stats col width
'Set numberformat for stats (limit range to keep count a whole number)
Range(Cells(3, iCol + 2), Cells(15, iCol + 2)).NumberFormat = "0.0"
'All Atis% column title and width
'Values are calculate from preceding Aair column
iCol = iCol + 4
Cells(1, iCol).Value = "All Atis"
Cells(1, iCol).Font.Bold = True
Cells(2, iCol).Value = "Atis (%)"
Columns(iCol).ColumnWidth = Len("Atis (%)")
'Atis % = 100-Aair%
Cells(3, iCol).FormulaR1C1 = "=100-(+RC[-4])"
Cells(3, iCol).Select
Selection.Copy
Range(Cells(3, iCol), Cells(lEndRow, iCol)).Select 'Endrow from Aair column
ActiveSheet.Paste
'Convert formulas to values
Range(Cells(3, iCol), Cells(lEndRow, iCol)).Select
Selection.Copy
Cells(3, iCol).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
'All column number format
Range(Cells(3, iCol), Cells(lEndRow, iCol)).NumberFormat = "0.0"
'All Aair descriptive statistics
Application.Run "ATPVBAEN.XLA!Descr", _
Range(Cells(2, iCol), Cells(lEndRow, iCol)), _
Cells(2, iCol + 1), "C", True, True
Columns(iCol + 1).ColumnWidth = 16 'stats col width
'Set numberformat for stats (limit range to keep count a whole number)
Range(Cells(3, iCol + 2), Cells(15, iCol + 2)).NumberFormat = "0.0"
'All Atis column title and width
iCol = iCol + 4
Cells(1, iCol).Value = "All Atis"
Cells(1, iCol).Font.Bold = True
Cells(2, iCol).Value = "Atis (µm²)"
Columns(iCol).ColumnWidth = Len("Atis (µm²)")
'Paste each column into all column
For iRangeCnt = LBound(aRangeAtis) To UBound(aRangeAtis)
aRangeAtis(iRangeCnt).Select
Selection.Copy
'Find last row of destination column
Columns(iCol).End(xlDown).Select
lEndRow = ActiveCell.Row
Cells(lEndRow + 1, iCol).Select
'Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
ActiveSheet.Paste
Next
'Find last row of destination column
Columns(iCol).End(xlDown).Select
lEndRow = ActiveCell.Row
'All column number format
Range(Cells(3, iCol), Cells(lEndRow, iCol)).NumberFormat = "0.0"
'All Atis descriptive statistics
Application.Run "ATPVBAEN.XLA!Descr", _
Range(Cells(2, iCol), Cells(lEndRow, iCol)), _
Cells(2, iCol + 1), "C", True, True
Columns(iCol + 1).ColumnWidth = 16 'stats col width
'Set numberformat for stats (limit range to keep count a whole number)
Range(Cells(3, iCol + 2), Cells(15, iCol + 2)).NumberFormat = "0.0"
CenterColTitles
PageSetup
iAllDataCol = iAllDataCol + 1
'Move All Aalv data to Aalv sheet
'NewSheet.Name still refers to data sheet since it was the last sheet created
Worksheets(NewSheet.Name).Activate 'select data sheet
iCol = iCol - 16
Columns(iCol).End(xlDown).Select 'Find last row
lEndRow = ActiveCell.Row
Range(Cells(3, iCol), Cells(lEndRow, iCol)).Select
Selection.Cut
Worksheets("All Aalv").Activate
Cells(2, iAllDataCol).Select
ActiveSheet.Paste
'Reserve row 1 for titles
Cells(1, iAllDataCol).Font.Bold = True
Cells(1, iAllDataCol).Value = NewSheet.Name
'Move All stats to All sheet
'NewSheet.Name still refers to data sheet since it was the last sheet created
Worksheets(NewSheet.Name).Activate
Range(Cells(2, iCol + 1), Cells(16, iCol + 2)).Select
Selection.Copy
Cells(1, 1).Select 'Reset data sheet position
Worksheets("All Aalv").Activate
Cells(iAllStatsRow + 1, iAllStatsCol).Select
ActiveSheet.Paste
Columns(iAllStatsCol).ColumnWidth = 16 'stats col width
Columns(iAllStatsCol + 1).ColumnWidth = 12
'Group title
Cells(iAllStatsRow, iAllStatsCol).Select
With Selection
.Value = NewSheet.Name & " (All)"
.Font.Bold = True
End With
'Copy mean value into All Means column
'Group title
Cells(1, iAllMeansCol).Value = "All Means"
Cells(1, iAllMeansCol).Font.Bold = True
'Copy group stats mean into All Means column
Cells(iAllStatsRow + 3, iAllStatsCol + 1).Select
Selection.Copy
Cells(iAllMeansRow, iAllMeansCol).Select
ActiveSheet.Paste
Cells(1, 1).Select 'Reset all sheet position
'Move All Asurf column to Asurf sheet
Worksheets(NewSheet.Name).Activate 'select data sheet
iCol = iCol + 4
Columns(iCol).End(xlDown).Select 'Find last row
lEndRow = ActiveCell.Row
Range(Cells(3, iCol), Cells(lEndRow, iCol)).Select
Selection.Cut
Worksheets("All Asurf").Activate
Cells(2, iAllDataCol).Select
ActiveSheet.Paste
'Reserve row 1 for titles
Cells(1, iAllDataCol).Font.Bold = True
Cells(1, iAllDataCol).Value = NewSheet.Name
'Move All stats to All sheet
'NewSheet.Name still refers to data sheet since it was the last sheet created
Worksheets(NewSheet.Name).Activate
Range(Cells(2, iCol + 1), Cells(16, iCol + 2)).Select
Selection.Copy
Cells(1, 1).Select 'Reset data sheet position
Worksheets("All Asurf").Activate
Cells(iAllStatsRow + 1, iAllStatsCol).Select
ActiveSheet.Paste
Columns(iAllStatsCol).ColumnWidth = 16 'stats col width
Columns(iAllStatsCol + 1).ColumnWidth = 12
'Group title
Cells(iAllStatsRow, iAllStatsCol).Select
With Selection
.Value = NewSheet.Name & " (All)"
.Font.Bold = True
End With
'Copy mean value into All Means column
'Group title
Cells(1, iAllMeansCol).Value = "All Means"
Cells(1, iAllMeansCol).Font.Bold = True
'Copy group stats mean into All Means column
Cells(iAllStatsRow + 3, iAllStatsCol + 1).Select
Selection.Copy
Cells(iAllMeansRow, iAllMeansCol).Select
ActiveSheet.Paste
Cells(1, 1).Select 'Reset all sheet position
'Move All Aair column to Aair sheet
Worksheets(NewSheet.Name).Activate 'select data sheet
iCol = iCol + 4
Columns(iCol).End(xlDown).Select 'Find last row
lEndRow = ActiveCell.Row
Range(Cells(3, iCol), Cells(lEndRow, iCol)).Select
Selection.Cut
Worksheets("All Aair%").Activate
Cells(2, iAllDataCol).Select
ActiveSheet.Paste
'Reserve row 1 for titles
Cells(1, iAllDataCol).Font.Bold = True
Cells(1, iAllDataCol).Value = NewSheet.Name
'Move All stats to All sheet
'NewSheet.Name still refers to data sheet since it was the last sheet created
Worksheets(NewSheet.Name).Activate
Range(Cells(2, iCol + 1), Cells(16, iCol + 2)).Select
Selection.Copy
Cells(1, 1).Select 'Reset data sheet position
Worksheets("All Aair%").Activate
Cells(iAllStatsRow + 1, iAllStatsCol).Select
ActiveSheet.Paste
Columns(iAllStatsCol).ColumnWidth = 16 'stats col width
Columns(iAllStatsCol + 1).ColumnWidth = 12
'Group title
Cells(iAllStatsRow, iAllStatsCol).Select
With Selection
.Value = NewSheet.Name & " (All)"
.Font.Bold = True
End With
'Copy mean value into All Means column
'Group title
Cells(1, iAllMeansCol).Value = "All Means"
Cells(1, iAllMeansCol).Font.Bold = True
'Copy group stats mean into All Means column
Cells(iAllStatsRow + 3, iAllStatsCol + 1).Select
Selection.Copy
Cells(iAllMeansRow, iAllMeansCol).Select
ActiveSheet.Paste
Cells(1, 1).Select 'Reset all sheet position
'Move All Atis% column to Atis% sheet
Worksheets(NewSheet.Name).Activate 'select data sheet
iCol = iCol + 4
Columns(iCol).End(xlDown).Select 'Find last row
lEndRow = ActiveCell.Row
Range(Cells(3, iCol), Cells(lEndRow, iCol)).Select
Selection.Cut
Worksheets("All Atis%").Activate
Cells(2, iAllDataCol).Select
ActiveSheet.Paste
'Reserve row 1 for titles
Cells(1, iAllDataCol).Font.Bold = True
Cells(1, iAllDataCol).Value = NewSheet.Name
'Move All stats to All sheet
'NewSheet.Name still refers to data sheet since it was the last sheet created
Worksheets(NewSheet.Name).Activate
Range(Cells(2, iCol + 1), Cells(16, iCol + 2)).Select
Selection.Copy
Cells(1, 1).Select 'Reset data sheet position
Worksheets("All Atis%").Activate
Cells(iAllStatsRow + 1, iAllStatsCol).Select
ActiveSheet.Paste
Columns(iAllStatsCol).ColumnWidth = 16 'stats col width
Columns(iAllStatsCol + 1).ColumnWidth = 12
'Group title
Cells(iAllStatsRow, iAllStatsCol).Select
With Selection
.Value = NewSheet.Name & " (All)"
.Font.Bold = True
End With
'Copy mean value into All Means column
'Group title
Cells(1, iAllMeansCol).Value = "All Means"
Cells(1, iAllMeansCol).Font.Bold = True
'Copy group stats mean into All Means column
Cells(iAllStatsRow + 3, iAllStatsCol + 1).Select
Selection.Copy
Cells(iAllMeansRow, iAllMeansCol).Select
ActiveSheet.Paste
Cells(1, 1).Select 'Reset all sheet position
'Move All Atis column to Atis sheet
Worksheets(NewSheet.Name).Activate 'select data sheet
iCol = iCol + 4
Columns(iCol).End(xlDown).Select 'Find last row
lEndRow = ActiveCell.Row
Range(Cells(3, iCol), Cells(lEndRow, iCol)).Select
Selection.Cut
Cells(1, 1).Select 'Reset data sheet position
Worksheets("All Atis").Activate
Cells(2, iAllDataCol).Select
ActiveSheet.Paste
'Reserve row 1 for titles
Cells(1, iAllDataCol).Font.Bold = True
Cells(1, iAllDataCol).Value = NewSheet.Name
'Move All stats to All sheet
'NewSheet.Name still refers to data sheet since it was the last sheet created
Worksheets(NewSheet.Name).Activate
Range(Cells(2, iCol + 1), Cells(16, iCol + 2)).Select
Selection.Copy
Cells(1, 1).Select 'Reset data sheet position
Worksheets("All Atis").Activate
Cells(iAllStatsRow + 1, iAllStatsCol).Select
ActiveSheet.Paste
Columns(iAllStatsCol).ColumnWidth = 16 'stats col width
Columns(iAllStatsCol + 1).ColumnWidth = 12
'Group title
Cells(iAllStatsRow, iAllStatsCol).Select
With Selection
.Value = NewSheet.Name & " (All)"
.Font.Bold = True
End With
'Copy mean value into All Means column
'Group title
Cells(1, iAllMeansCol).Value = "All Means"
Cells(1, iAllMeansCol).Font.Bold = True
'Copy group stats mean into All Means column
Cells(iAllStatsRow + 3, iAllStatsCol + 1).Select
Selection.Copy
Cells(iAllMeansRow, iAllMeansCol).Select
ActiveSheet.Paste
Cells(1, 1).Select 'Reset all sheet position
iAllMeansRow = iAllMeansRow + 1
iAllStatsRow = iAllStatsRow + 17
Else
MsgBox "No files found in folder " & vSelectedItem, vbExclamation, "Message"
End If
End With
Next vSelectedItem
'-------All means
Worksheets("All Aalv").Activate
iCol = iAllMeansCol
'Find last row of destination column
Columns(iCol).End(xlDown).Select
lEndRow = ActiveCell.Row
'All column number format
Range(Cells(1, iCol), Cells(lEndRow, iCol)).NumberFormat = "0.0"
'Descriptive statistics
'Descr function: input range, output range, grouped, labels, summary, ds_large, ds_small, confidence
'Grouped="C" for columns, "R" for rows
Application.Run "ATPVBAEN.XLA!Descr", _
Range(Cells(1, iCol), Cells(lEndRow, iCol)), _
Cells(1, iCol + 1), "C", True, True
Columns(iCol + 1).ColumnWidth = 16 'stats col width
'Stats column title
Cells(1, iCol + 1).Value = "Aalv (µm²)"
'Columns(iCol + 1).ColumnWidth = Len("Aalv (µm²)")
'Set numberformat for stats (limit range to keep count a whole number)
Range(Cells(3, iCol + 2), Cells(14, iCol + 2)).NumberFormat = "0.0"
'All means
Worksheets("All Asurf").Activate
iCol = iAllMeansCol
'Find last row of destination column
Columns(iCol).End(xlDown).Select
lEndRow = ActiveCell.Row
'All column number format
Range(Cells(1, iCol), Cells(lEndRow, iCol)).NumberFormat = "0.0"
'Descriptive statistics
Application.Run "ATPVBAEN.XLA!Descr", _
Range(Cells(1, iCol), Cells(lEndRow, iCol)), _
Cells(1, iCol + 1), "C", True, True
Columns(iCol + 1).ColumnWidth = 16 'stats col width
'Stats column title
Cells(1, iCol + 1).Value = "Asurf (µm)"
'Columns(iCol + 1).ColumnWidth = Len("Asurf (µm)")
'Set numberformat for stats (limit range to keep count a whole number)
Range(Cells(3, iCol + 2), Cells(14, iCol + 2)).NumberFormat = "0.0"
'All means
Worksheets("All Aair%").Activate
iCol = iAllMeansCol
'Find last row of destination column
Columns(iCol).End(xlDown).Select
lEndRow = ActiveCell.Row
'All column number format
Range(Cells(1, iCol), Cells(lEndRow, iCol)).NumberFormat = "0.0"
'Descriptive statistics
Application.Run "ATPVBAEN.XLA!Descr", _
Range(Cells(1, iCol), Cells(lEndRow, iCol)), _
Cells(1, iCol + 1), "C", True, True
Columns(iCol + 1).ColumnWidth = 16 'stats col width
'Stats column title
Cells(1, iCol + 1).Value = "Aair (%)"
'Columns(iCol + 1).ColumnWidth = Len("Aair (%)")
'Set numberformat for stats (limit range to keep count a whole number)
Range(Cells(3, iCol + 2), Cells(14, iCol + 2)).NumberFormat = "0.0"
'All means
Worksheets("All Atis%").Activate
iCol = iAllMeansCol
'Find last row of destination column
Columns(iCol).End(xlDown).Select
lEndRow = ActiveCell.Row
'All column number format
Range(Cells(1, iCol), Cells(lEndRow, iCol)).NumberFormat = "0.0"
'Descriptive statistics
Application.Run "ATPVBAEN.XLA!Descr", _
Range(Cells(1, iCol), Cells(lEndRow, iCol)), _
Cells(1, iCol + 1), "C", True, True
Columns(iCol + 1).ColumnWidth = 16 'stats col width
'Stats column title
Cells(1, iCol + 1).Value = "Atis (%)"
'Columns(iCol + 1).ColumnWidth = Len("Atis (%)")
'Set numberformat for stats (limit range to keep count a whole number)
Range(Cells(3, iCol + 2), Cells(14, iCol + 2)).NumberFormat = "0.0"
'All means
Worksheets("All Atis").Activate
iCol = iAllMeansCol
'Find last row of destination column
Columns(iCol).End(xlDown).Select
lEndRow = ActiveCell.Row
'All column number format
Range(Cells(1, iCol), Cells(lEndRow, iCol)).NumberFormat = "0.0"
'Descriptive statistics
Application.Run "ATPVBAEN.XLA!Descr", _
Range(Cells(1, iCol), Cells(lEndRow, iCol)), _
Cells(1, iCol + 1), "C", True, True
Columns(iCol + 1).ColumnWidth = 16 'stats col width
'Stats column title
Cells(1, iCol + 1).Value = "Atis (µm²)"
'Columns(iCol + 1).ColumnWidth = Len("Atis (µm²)")
'Set numberformat for stats (limit range to keep count a whole number)
Range(Cells(3, iCol + 2), Cells(14, iCol + 2)).NumberFormat = "0.0"
'-------- end of All means
'Set object variables to Nothing.
Set fd = Nothing
Set fs = Nothing
'Save workbook
sFileSaveName = Application.GetSaveAsFilename(NewBook.Title & "_A.xls", "Excel Files (*.xls), *.xls")
If sFileSaveName <> "False" Then
On Error Resume Next 'ignore rte 1004 if No reply to overwrite
NewBook.SaveAs sFileSaveName
'NewBook.SaveAs fileName:=NewBook.Title & "_A.xls"
On Error GoTo err_AP_No_Edge_Multi
End If
exit_AP_No_Edge_Multi:
Application.ScreenUpdating = True
Exit Sub
err_AP_No_Edge_Multi:
'If same folder chosen (only when testing) increment the sheet name to prevent duplicate sheet error.
If Left(Err.Description, 55) = "Cannot rename a sheet to the same name as another sheet" Then
NewSheet.Name = Mid$(vSelectedItem, InStrRev(vSelectedItem, "\") + 1) & " Copy" & iDupCnt
iDupCnt = iDupCnt + 1
Resume Next
Else
MsgBox Err.Description
Resume exit_AP_No_Edge_Multi
End If
End Sub
