代码循环访问特定值范围的列

嗨，我想要一个代码，允许循环通过表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 

在你的代码上面，build议你做两个修改build议。

@Niva我还没有findCountifs或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 

另外，不知道你真的需要将其转换为布尔值。