Question

您好，我想要一个允许循环播放工作表A列的代码，将值> 0的列复制到工作表B.是否有一些代码可以帮助解决前一个论坛问题的一些答案，但仍然有问题，因为它似乎在粘贴目的地不起作用！非常感谢一些帮助。代码如下：

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

Answer 1

您继续粘贴到第3列。尝试：

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

Answer 2

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上面建议的2个更改代码将起作用。

@Niva我还没有找出Countifs或CountA没有给出预期结果的基本原因。为了满足您的直接要求，您可以使用其他程序删除Sheet1中的空白。请将其设为活动表并使用以下程序。

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

Answer 3

为什么要使用复制和粘贴？我尽量避免复制和粘贴，因为它依赖于操作系统的剪贴板，可供其他应用程序使用。

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

也是这样：

Application.CountIfs

应该是这样的：

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

另外，不确定您是否真的需要将其转换为布尔值。

代码循环遍历特定值范围的列

3 个答案: