Code to loop through columns for specific value range

Question

Hi there I want a code which allows to loop through the columns of Sheet A, and columns which have values>0 would be copied to Sheet B. Did a code with help of some answers from the previous forum question but still having issues as it does not seem to work at the paste destination! Some help would be very much appreciated. The code is as follows:

Sub TestPasteColumnData3()

Dim lastcol As Long
Dim j As Long

    With Worksheets("WF - L12 (3)")
    lastcol = .Cells(4, Columns.Count).End(xlToLeft).Column
       For j = 3 To lastcol
        If CBool(Application.CountIfs(.Columns(j), ">0")) Then
            .Columns(j).Copy Destination:=Worksheets("Sheet1").Columns(3)
        Else
            MsgBox ("No Value")
            Exit Sub
        End If
        Next
    End With

    MsgBox ("Done")
End Sub

dePatinkin · Accepted Answer · 2016-05-11 02:05:18Z

1

You keep pasting to column 3. Try:

.Columns(j).Copy Destination:=Worksheets("Sheet1").Columns(j)

answered May 11, 2016 at 2:05

dePatinkin

2,2991 gold badge18 silver badges15 bronze badges

Sign up to request clarification or add additional context in comments.

3 Comments

dePatinkin Over a year ago

What do you get? Does your code ever reach this line?

Niva Over a year ago

Hi sorry it works now but it still pastes columns which has no values >0

dePatinkin Over a year ago

Do the COUNTIFS as a formula in the sheet, and see if you get correct values. =COUNTIFS(C:C,">0"), =COUNTIFS(D:D,">0"), etc.

skkakkar · Accepted Answer · 2016-05-11 05:55:17Z

1

Sub TestPasteColumnData3()

Dim lastcol As Long
Dim j As Long

    With Worksheets("WF - L12 (3)")
    lastcol = .Cells(4, Columns.Count).End(xlToLeft).Column
       For j = 3 To lastcol
      'change >0 to <>0 and 3 to j        
      If CBool(Application.CountIfs(.Columns(j), "<>0")) Then
            .Columns(j).Copy Destination:=Worksheets("Sheet1").Columns(j)
        Else
            MsgBox ("No Value")
            Exit Sub
        End If
        Next
    End With

    MsgBox ("Done")
End Sub

Pl make 2 changes suggested above your code will work.

@Niva I am yet to find out basic reason of Countifs or CountA not giving desired results. For your immediate requirements you can use an additional program to delete blanks in Sheet1. Please make it Active Sheet and use the following program.

Sub DeleteBlankColumns()

  With Worksheets("Sheet1")
    Dim lastColumn As Long
    lastColumn = ActiveSheet.Cells(2, Columns.Count).End(xlToLeft).Column
   'MsgBox lastColumn
    Dim lastRow As Long
    Dim rng As Range

   Set rng = ActiveSheet.Cells

     lastRow = rng.Find(What:="*", After:=rng.Cells(1), Lookat:=xlPart, LookIn:=xlFormulas, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False).Row

    'MsgBox lastRow
   'Step1:  Declare your variables.
    Dim MyRange As Range
    Dim iCounter As Long
   'Step 2:  Define the target Range.
    Set MyRange = ActiveSheet.Range(Cells(1, 1), Cells(lastRow, lastColumn))

   'Step 3:  Start reverse looping through the range.

    For iCounter = MyRange.Columns.Count To 1 Step -1
   'Debug.Print iCounter
   'Step 4: If entire column is empty then delete it.
       Debug.Print Application.CountA(Columns(iCounter).EntireColumn) = 0
       If Application.CountA(Columns(iCounter).EntireColumn) = 0 Then
       Columns(iCounter).Delete
       End If
  'Step 5: Increment the counter down
    Next iCounter
  End With
End Sub

edited May 11, 2016 at 5:55

answered May 11, 2016 at 2:42

skkakkar

2,8482 gold badges20 silver badges32 bronze badges

13 Comments

skkakkar Over a year ago

@Niva if you keep ">0" it will give false even for a non empty cell but "<>0" will correctly work and give true value for a non empty cell.

Niva Over a year ago

Sorry but it still does not work:/ Worksheet still remains blank after runing the code

skkakkar Over a year ago

@Niva It works for me. Should I upload sample file to drop box

skkakkar Over a year ago

I have uploaded sample file <dropbox.com/s/4kj3iehzp4f8mnr/copy_to_loop.xlsm?dl=0>

skkakkar Over a year ago

@Niva if dropbox does not suit you then pl suggest alternatives.

|

Dan Donoghue · Accepted Answer · 2016-05-11 02:59:43Z

0

Why use copy and paste? I try to avoid copy and paste because it relies on the OS's clipboard which can be used by other applications.

Worksheets("Sheet1").Columns(j).value = Columns(j).value

also this:

Application.CountIfs

should be this:

Application.worksheetfunction.CountIf 'Note, don't need countifS for only 1 criteria

Also, not sure that you really need to convert it to a boolean.

answered May 11, 2016 at 2:59

Dan Donoghue

6,2662 gold badges20 silver badges36 bronze badges

1 Comment

Niva Over a year ago

Did the above but it still copies blank columns. I think it has something to do with the j variable because when i hardcode it , the countif function works

Collectives™ on Stack Overflow

Code to loop through columns for specific value range

3 Answers 3

3 Comments

13 Comments

1 Comment

Your Answer

Hot Network Questions

Collectives™ on Stack Overflow

3 Answers 3

3 Comments

13 Comments

1 Comment

Your Answer

Sign up or log in

Post as a guest

Related