CODEWITHSUNDEEP
vbaexcel
Niva
Niva

Reputation: 298

Code to loop through columns for specific value range

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

Upvotes: 0

Views: 86

Answers (3)

skkakkar
skkakkar

Reputation: 2828

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

Upvotes: 1

Dan Donoghue
Dan Donoghue

Reputation: 6206

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.

Upvotes: 0

dePatinkin
dePatinkin

Reputation: 2289

You keep pasting to column 3. Try:

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

Upvotes: 1

Related Questions