Condition # Of Empty Cell in Column to COPY. How ?

[FlaShow]

Hello Friends,

I'm trying to COPY Columns from on Worksheet to a New Created One But would like to add a condition before the Actual Copy which is if the Column have more than 10 Empty Cells do not Copy this Column and Move to the next One to check So How i should organize my Code to do that.

Dim wsCopy As Worksheet, wsDest As Worksheet
Dim CopyLastRow As Long, CopyLastColumn As Long

'Open Absent Sheet
    Workbooks.Open "C:\Users\Working\Desktop\absent11d7.xlsx"
    
'Set varialbe for copy and destination sheets
    Set wsCopy = Workbooks("absent11d7.xlsx").Worksheets(1)

'1. Find last used row in the copy range based on data in column A
    CopyLastRow = wsCopy.Cells(wsCopy.Rows.Count, 1).End(xlUp).Row

'2. Fine last used column in copy range base
    CopyLastColumnNumber = wsCopy.Cells(1, Columns.Count).End(xlToLeft).Column
'Convert To Column Letter
    CopyLastColumnLetter = Split(Cells(1, CopyLastColumnNumber).Address, "$")(1)
    
    n = WorksheetFunction.CountA(Range("D2:D" & CopyLastRow))
    MsgBox "The number of non-blank cells in column is " & n
    
    'For i = 5 To 5
    'Set Rng = Intersect(Columns(i), ActiveSheet.UsedRange)
    'On Error Resume Next
    'b = Rng.Cells.SpecialCells(xlCellTypeBlanks).Count
    'n = Rng.Cells.Count - b
    'On Error GoTo 0
    'MsgBox "The number of non-blank cells in column " & Columns(i).Column & " is " & n
    'Next i
  
'Step 1 Copy the data
    wsCopy.Range("A1:" & CopyLastColumnLetter & CopyLastRow).Copy
'Step 2 Create a new workbook
    Workbooks.Add
'Step 3 Paste the data
    ActiveSheet.Paste Destination:=Range("A1")
'Step 4 Turn off application alerts
    Application.DisplayAlerts = False
'Step 5 Save the newly created workbook
    ActiveWorkbook.SaveAs _
    Filename:=ThisWorkbook.Path & "\NewAbsentData.xlsx"
'Step 6 Turn application alerts back on
    Application.DisplayAlerts = True

 

[mumps]

Glad it worked out.