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
 

Excel Facts

Can a formula spear through sheets?
Use =SUM(January:December!E7) to sum E7 on all of the sheets from January through December
Is there any hint that can help me to achieve this task ?
 
Upvote 0
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
 
Upvote 0
Thanks mumps,

Not sure it did not work with me. Could you check this file maybe it has a problem ?
 
Upvote 0
Your link takes me to the sign-in page. I would need a direct link to your file.
 
Upvote 0
Sorry to hear that. This is new direct link
 
Upvote 0
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.
 
Upvote 0
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 ?
 
Upvote 0
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
 
Upvote 0
Solution

Forum statistics

Threads
1,213,484
Messages
6,113,923
Members
448,533
Latest member
thietbibeboiwasaco

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top