Option Explicit
Sub CopyColumnToWorksheets()
Dim wb1 As Workbook
Dim wb2 As Workbook
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim rng As Range
Dim rng2 As Range
Dim blHiddenRowFound As Boolean
Dim dblHeadingRow As Double
Dim intRowHeight As Integer
Dim dblKount As Double
Dim dblKount2 As Double
Dim intKount3 As Integer
Dim dblRequiredColumn As Double
Dim dblWorksheetKount As Double
Dim dblNumberOfColumns As Double
Dim strWSname As String
Dim dblNumberOfRows As Double
Dim dblSourceRow As Double
Dim dblTargetRow As Double
'
Dim oFind As Object ' <=====
Dim varValueCheck As Variant ' <=====
'
Application.ScreenUpdating = False
' We are assuming that headings are in Row 1
dblHeadingRow = 1
' Get the required column:
dblRequiredColumn = ActiveCell.Column
' Initialise
Set wb1 = ActiveWorkbook
Set ws1 = wb1.ActiveSheet
dblWorksheetKount = wb1.Worksheets.Count
' Get number of columns:
dblNumberOfColumns = GetLastColumn
' Get last row:
'dblNumberOfRows = Cells(ws1.Rows.Count, dblRequiredColumn).End(xlUp).Row
' The above will be OK if all rows have a value but if not:
Set rng = ws1.UsedRange
dblNumberOfRows = rng.Rows.Count
' Create new workbook:
Set wb2 = Workbooks.Add
' Copy to new worksheets:
For dblSourceRow = (dblHeadingRow + 1) To dblNumberOfRows
Application.StatusBar = "Processing row " & dblSourceRow & " of " & dblNumberOfRows & " rows"
' Only visible rows:
If ws1.Rows(dblSourceRow).Hidden = False Then
strWSname = ws1.Cells(dblSourceRow, dblRequiredColumn).Value
If Trim(strWSname) = "" Then
' allow for blank cell
strWSname = "Not Known"
End If
' Remove invalid characters for worksheet name:
strWSname = Replace(strWSname, ":", "")
strWSname = Replace(strWSname, "\", "")
strWSname = Replace(strWSname, "/", "")
strWSname = Replace(strWSname, "?", "")
strWSname = Replace(strWSname, "*", "")
strWSname = Replace(strWSname, "[", "")
strWSname = Replace(strWSname, "]", "")
' add to above list if necessary
If Trim(strWSname) = "" Then
strWSname = "Not Known"
End If
If Len(strWSname) > 31 Then
strWSname = Left(strWSname, 31)
End If
'
On Error GoTo Error_Need_New_Worksheet '
'
wb2.Activate
wb2.Worksheets(strWSname).Activate
'
On Error GoTo 0
'
wb2.ActiveSheet.Name = strWSname
If wb2.ActiveSheet.Name = strWSname Then
Set ws2 = wb2.ActiveSheet
Else
MsgBox "Error - unable to access new worksheet" & vbCrLf & vbCrLf & _
"Process abandoned", vbCritical + vbOKOnly, "Error"
Exit Sub
End If
' Get last row in new worksheet
dblTargetRow = ws2.Cells(ws2.Rows.Count, dblRequiredColumn).End(xlUp).Row + 1
' Check for duplicate in Column F
varValueCheck = ws1.Cells(dblSourceRow, 6) ' <===== Column F check
Set rng = ws2.Range(Cells(2, 6), Cells(dblTargetRow - 1, 6))
Set oFind = rng.Find(varValueCheck, LookIn:=xlValues, LookAt:=xlWhole)
If oFind Is Nothing Then
' duplicate not found in column F
For dblKount = 1 To dblNumberOfColumns
If ws1.Columns(dblKount).Hidden = False Then
ws2.Cells(dblTargetRow, dblKount).Value = ws1.Cells(dblSourceRow, dblKount).Value
End If
Next dblKount
' copy formats
ws1.Activate
Set rng = ws1.Range(Cells(dblSourceRow, 1), Cells(dblSourceRow, dblNumberOfColumns))
rng.Copy
intRowHeight = rng.RowHeight
ws2.Activate
Set rng2 = ws2.Range(Cells(dblTargetRow, 1), Cells(dblTargetRow, dblNumberOfColumns))
rng2.PasteSpecial xlPasteFormats
rng2.RowHeight = intRowHeight
Application.CutCopyMode = False
'
' Check to make sure that last row can be found on future loops
' by making sure that the "Required Column" has content:
If ((ws2.Cells(dblTargetRow, dblRequiredColumn).Value = "") Or (ws2.Cells(dblTargetRow, dblRequiredColumn).Value = " ")) Then
ws2.Cells(dblTargetRow, dblRequiredColumn).Value = "?????"
End If
'
ws1.Activate
End If
Else
blHiddenRowFound = True
End If
'
Next dblSourceRow
'
' Data copied, now copy headers and hide columns where necessary:
'
Application.StatusBar = "Copying headers ....."
dblWorksheetKount = wb2.Worksheets.Count
For dblKount2 = 1 To dblWorksheetKount
Set ws2 = wb2.Worksheets(dblKount2)
For intKount3 = 1 To dblHeadingRow
ws1.Activate
Set rng = ws1.Range(Cells(intKount3, 1), Cells(intKount3, dblNumberOfColumns))
ws2.Activate
Set rng2 = ws2.Range(Cells(intKount3, 1), Cells(intKount3, dblNumberOfColumns))
rng.Copy Destination:=rng2
Next intKount3
' format worksheet
ws2.Cells.Columns.AutoFit
ws2.Cells.Rows.AutoFit
ws2.Range("A1").Select
Next dblKount2
' SORT worksheets:
Application.StatusBar = "SORTing worksheets ....."
wb2.Activate
SortWorksheets
On Error Resume Next
Application.DisplayAlerts = False
wb2.Worksheets("Sheet1").Delete
wb2.Worksheets("Sheet2").Delete
wb2.Worksheets("Sheet3").Delete
Application.DisplayAlerts = True
'
wb1.Activate
wb1.Worksheets(1).Activate
ActiveSheet.Range("A1").Select
wb2.Activate
wb2.Worksheets(1).Activate
ActiveSheet.Range("A1").Select
'
On Error Resume Next
Application.ScreenUpdating = True
'
Application.StatusBar = ""
Set wb1 = Nothing
Set wb2 = Nothing
Set ws1 = Nothing
Set ws2 = Nothing
Set rng = Nothing
Set rng2 = Nothing
'
If blHiddenRowFound Then
MsgBox "Processing completed." & vbCrLf & vbCrLf & _
"Please check results." & vbCrLf & vbCrLf & _
"Note: only visible rows have been copied", vbInformation + vbOKOnly, "Action completed"
Else
MsgBox "Processing completed." & vbCrLf & vbCrLf & _
"Please check results.", vbInformation + vbOKOnly, "Action completed"
End If
'
Exit Sub
Error_Need_New_Worksheet:
If wb2.Worksheets.Count >= 255 Then
MsgBox "Too many worksheets are needed to complete the request - " & _
"maximum = 255" & vbCrLf & vbCrLf & "Process abandoned", vbCritical + vbOKOnly, "Error"
Exit Sub
End If
wb2.Worksheets.Add
Resume Next
End Sub
Private Sub SortWorksheets()
Dim Cnt As Double
Dim N As Double
Dim M As Double
Dim WS As Worksheet
Dim check1 As String
Dim check2 As String
Set WS = ActiveSheet
Cnt = ActiveWorkbook.Worksheets.Count
For M = 1 To Cnt
For N = M To Cnt
check1 = Worksheets(N).Name
check2 = Worksheets(M).Name
If Worksheets(N).Name < Worksheets(M).Name Then
Worksheets(N).Move Before:=Worksheets(M)
End If
Next N
Next M
End Sub
Private Function GetLastColumn() As Double
Dim dblLooper As Double
Dim dblNumberOfColumns As Double
' WARNING: If Autofilter is on and one or more columns are filtered, then
' "ActiveSheet.Cells.Find( etc.) returns a value of 1 ?@!!
If ActiveSheet.AutoFilterMode Then
For dblLooper = ActiveSheet.Columns.Count To 1 Step -1
If ((Cells(2, dblLooper).Value <> "") And (Cells(2, dblLooper).Value <> " ")) Then
Exit For
End If
Next dblLooper
dblNumberOfColumns = dblLooper
Else
dblNumberOfColumns = ActiveSheet.Cells.Find(what:="*", after:=[A1], searchorder:=xlByColumns, searchdirection:=xlPrevious).Column
End If
' allow for hidden columns
For dblLooper = 0 To 1 Step 0
If dblNumberOfColumns > ActiveSheet.Columns.Count Then
Exit For
End If
If ActiveSheet.Columns(dblNumberOfColumns + 1).Hidden = True Then
dblNumberOfColumns = dblNumberOfColumns + 1
Else
Exit For
End If
Next dblLooper
GetLastColumn = dblNumberOfColumns
End Function
