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

FlaShow

New Member
Joined
Nov 23, 2020
Messages
10
Office Version
  1. 365
Platform
  1. Windows
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.
VBA Code:
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
 

Some videos you may like

Excel Facts

Select a hidden cell
Somehide hide payroll data in column G? Press F5. Type G1. Enter. Look in formula bar while you arrow down through G.

FlaShow

New Member
Joined
Nov 23, 2020
Messages
10
Office Version
  1. 365
Platform
  1. Windows
Is there any hint that can help me to achieve this task ?
 

mumps

Well-known Member
Joined
Apr 11, 2012
Messages
9,989
Try:
VBA Code:
Sub CopyCols()
    Application.ScreenUpdating = False
    Dim wsCopy As Worksheet, WB As Workbook, x As Long, LastRow As Long, lCol As Long
    Set WB = ThisWorkbook
    Workbooks.Open "C:\Users\Working\Desktop\absent11d7.xlsx"
    Set wsCopy = Sheets(1)
    Workbooks.Add 1
    With wsCopy
        LastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
        lCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
        For x = 1 To lCol
            If WorksheetFunction.CountA(.Columns(x)) >= LastRow - 10 Then
                .Columns(x).Copy Cells(1, Columns.Count).End(xlToLeft).Offset(0, 1)
            End If
        Next x
    End With
    Columns(1).Delete
    Application.DisplayAlerts = False
    ActiveWorkbook.SaveAs Filename:=WB.Path & "\NewAbsentData.xlsx"
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub
 

FlaShow

New Member
Joined
Nov 23, 2020
Messages
10
Office Version
  1. 365
Platform
  1. Windows
Thanks mumps,

Not sure it did not work with me. Could you check this file maybe it has a problem ?
 

mumps

Well-known Member
Joined
Apr 11, 2012
Messages
9,989

ADVERTISEMENT

Your link takes me to the sign-in page. I would need a direct link to your file.
 

FlaShow

New Member
Joined
Nov 23, 2020
Messages
10
Office Version
  1. 365
Platform
  1. Windows
Sorry to hear that. This is new direct link
 

mumps

Well-known Member
Joined
Apr 11, 2012
Messages
9,989

ADVERTISEMENT

For some reason, although the blank cells in the columns look blank, the macro is not recognizing them as blank. However, I can't figure out a reason for this. If I select the blank cells and manually delete their contents by pressing the DELETE key, then the macro recognizes them as blank. You would have to look at your original file to see if you can find a reason why this problem is happening. Click here to download your file and try the macro again.
 

FlaShow

New Member
Joined
Nov 23, 2020
Messages
10
Office Version
  1. 365
Platform
  1. Windows
This is my first thought too since i run a simple test using code below it always display 25 cells as of all have data which is strange ?!

VBA Code:
n = WorksheetFunction.CountA(Range("D2:D" & CopyLastRow))
    MsgBox "The number of non-blank cells in column is " & n

This file is exporting from Microsoft Teams using Insights for Student Attendance in meeting. Is there an auto solution to do that instead of manually doing it since it will be easer to delete those columns instead of using macros. right ?
 

mumps

Well-known Member
Joined
Apr 11, 2012
Messages
9,989
Try this version of the macro which will clear all the "blank" cells.
VBA Code:
Sub CopyCols()
    Application.ScreenUpdating = False
    Dim wsCopy As Worksheet, WB As Workbook, x As Long, LastRow As Long, lCol As Long
    Set WB = ThisWorkbook
    Workbooks.Open "C:\Users\Working\Desktop\absent11d7.xlsx"
    Set wsCopy = Sheets(1)
    wsCopy.Cells.Replace What:="", Replacement:="|", LookAt:=xlPart, SearchOrder:= _
        xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
    wsCopy.Cells.Replace What:="|", Replacement:="", LookAt:=xlPart, SearchOrder:= _
        xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
    Workbooks.Add 1
    With wsCopy
        LastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
        lCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
        For x = 1 To lCol
            If WorksheetFunction.CountA(.Columns(x)) >= LastRow - 11 Then
                .Columns(x).Copy Cells(1, Columns.Count).End(xlToLeft).Offset(0, 1)
            End If
        Next x
    End With
    Columns(1).Delete
    Application.DisplayAlerts = False
    ActiveWorkbook.SaveAs Filename:=WB.Path & "\NewAbsentData.xlsx"
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub
 
Solution

FlaShow

New Member
Joined
Nov 23, 2020
Messages
10
Office Version
  1. 365
Platform
  1. Windows
Awesome My Friend this is got the job done perfectly :)
 

Watch MrExcel Video

Forum statistics

Threads
1,119,015
Messages
5,575,564
Members
412,676
Latest member
Davejf81
Top