On Oct 28, 3:18 pm, "Bill Renaud"
wrote:
I revised the routine as follows. I added a function to determine the
actual data area in each column (both Data and Bin values). The logic
inside the For loop now only creates a Histogram if the number of cells on
the data worksheet is greater than 1 (column must have data besides the
column label). I used "Bins" for the name of the worksheet that has the Bin
values (you can change it back to "Sheet4", if you like).

I also name each Histogram worksheet as "Hist Column #", where "#" is the
column number where the data originated from.

'----------------------------------------------------------------------
Public Sub MakeHistograms()
Dim wsData As Worksheet 'Worksheet that contains the data.
Dim wsBins As Worksheet 'Worksheet with bin values.
Dim lngColumnsOfData As Long 'Number of columns of non-blank data.
Dim ilngColumn As Long 'Index of columns on Data and Bin sheets.
Dim rngData As Range
Dim rngBin As Range

Application.ScreenUpdating = False

Set wsData = ActiveSheet
Set wsBins = ActiveWorkbook.Worksheets("Bins")

lngColumnsOfData = wsData.UsedRange.Columns.Count

For ilngColumn = 1 To lngColumnsOfData
Set rngData = DataColumn(wsData.Cells(1, ilngColumn))

'Create Histogram only if column actually contains data.
'Assume row 1 is the header (column label).
If rngData.Cells.Count 1 _
Then
Set rngBin = DataColumn(wsBins.Cells(1, ilngColumn))

Application.Run "ATPVBAEN.XLA!Histogram", _
rngData, _
"", _
rngBin, _
False, False, True, True

'Newly-created Histogram worksheet is now active.
With ActiveSheet
.Name = "Hist Column " & ilngColumn
.Range("$A$1").Select
End With
End If
Next ilngColumn
End Sub

'----------------------------------------------------------------------
'DataColumn returns a range that is the extension of CellRow1
'down to the last non-blank cell in the same column.

Private Function DataColumn(CellRow1 As Range) As Range
Dim ws As Worksheet
Dim rngColumn As Range
Dim rngLastCell As Range

Set ws = CellRow1.Parent
Set rngColumn = CellRow1.EntireColumn
Set rngLastCell = rngColumn.Find _
(What:="*", _
After:=CellRow1, _
LookIn:=xlFormulas, _
LookAt:=xlWhole, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False)
If rngLastCell Is Nothing _
Then
'Column is totally blank; it contains no data!
Set DataColumn = CellRow1
Else
Set DataColumn = ws.Range(CellRow1, rngLastCell)
End If
End Function

--
Regards,
Bill Renaud

Bill, thanks a lot for this code too. I will give this a shot