macros基于条件复制范围到新的工作簿

可能重复：
macros条件复制范围到新的工作簿

我已经不成功地尝试为以下目的创buildmacros：将工作簿的范围复制到新的工作簿。 查看示例1中的第一个截图，我想实现的是将范围R4：AB6复制到新的工作簿中，并附加一个标准。 macros应该只复制活动单元格的行包含值的行。 示例1的第二个屏幕截图显示了macros的结果：基于提到的标准，粘贴范围的新工作簿。 我又增加了一个例子，使我需要更清楚。 在示例2中，屏幕截图2显示活动单元格为R7的起始位置。 运行macros的结果将是最终的屏幕截图，其中第4行和第5行已经与活动单元的行一起被复制，并且只有在该行不是空的情况下。

我真的很感激任何帮助，因为我对vba来说是个新手，而且很长一段时间以来一直在打破我的头脑！

Answer 1

这很粗糙，但希望这有助于..

Sub bks() Application.ScreenUpdating = False Dim WB1 As Workbook Dim WB2 As Workbook Dim name1 As String Dim name2 As String Dim colLet As String 'grab name of current workbook name1 = ThisWorkbook.Name Set WB1 = Workbooks(name1) 'create new workbook and set it Workbooks.Add.Activate name2 = ActiveWorkbook.Name Set WB2 = Workbooks(name2) WB1.Activate Dim i As Integer Dim j As Integer Dim k As Integer Dim m As Integer Dim mAdjust As Integer Dim x As Double 'set x equal to number of rows you have x = 100 Dim colSave() As Double ReDim colSave(x) j = 1 k = 1 'the `17` adjust the loop for the R column (17 columns over from 1) For i = 1 + 17 To 11 + 17 For m = 1 To x 'for each row of records, set the first report column to 1 via the array colSave(m) If i = 1 + 17 Then colSave(m) = 1 End If mAdjust = m + 5 WB2.Activate j = colSave(m) 'convert the column number to column letter If i > 26 Then colLet = Chr(Int((i - 1) / 26) + 64) & Chr(Int((i - 1) Mod 26) + 65) Else colLet = Chr(i + 64) End If WB1.Activate 'the conditional statements you wanted If Cells(mAdjust, i) <> "" Then Range(colLet & "4," & colLet & "5," & colLet & mAdjust).Activate Selection.Copy WB2.Activate Sheets("Sheet1").Cells((m - 1) * 5 + 1, j).Activate ActiveSheet.Paste colSave(m) = colSave(m) + 1 End If Next m Next i Application.ScreenUpdating = True WB2.Activate '`j` and `k` allow you to move the paste columns sperately based on your condition. End Sub