Question

我想我太盯着它，但我似乎无法弄清楚我做错了什么。我有一个页面上有3个不同的列表，如下所示：

我要做的是创建一个循环，查看列表中有多少项，然后在单独的工作表上复制每一行。因此，表2具有B2，C2，D2和B2的数据。 E2，片材3具有B3，C3，D3和B. E3，etcetra。

这是我的代码：

true

令人讨厌的部分是它在我改变“某事”之前有效，现在它已经不再......它现在只将最后一行复制到第一张表中。

任何人都可以看到我的错误吗？和奖金问题：循环是否可以简化，以便它自动转到下一张？

Answer 1

在我看来，好像当'i'最终增加到等于'LastRow'时，它将使用LastRow的数据写入第一张，增加超过'LastRow'（i = i + 1）的值并尝试写入剩下的纸张，其中的空白单元格存在于LastRow之外。然后退出循环，因为i> LastRow由4.

看起来您正在尝试将源工作表数据展平为单独的工作表，每个工作表一行。使用循环：

Dim workSht As Worksheet
For i = 2 To LastRow

    Set workSht = wb.Sheets("Sheet" & i)

    workSht.Range("A2") = wb1.Range("B" & i).Value
    workSht.Range("B2") = wb1.Range("C" & i).Value
    workSht.Range("C2") = wb1.Range("D" & i).Value
    workSht.Range("D2") = wb1.Range("E" & i).Value

Next i

Answer 2

试试这个：

For i = 2 to LastRow

    Worksheets("Sheet" & i).Range("A2").Value = wb1.Range("B" & i).value
    Worksheets("Sheet" & i).Range("B2").Value = wb1.Range("C" & i).value
    Worksheets("Sheet" & i).Range("C2").Value = wb1.Range("D" & i).value
    Worksheets("Sheet" & i).Range("D2").Value = wb1.Range("E" & i).value

Next

当您遍历行时，它会将每一行放在工作表上，并在名称中包含相应的行号。

Answer 3

尝试按照以下方式执行代码：

sht2.Range("A" & i) = wb1.Range("A" & i).Value
sht2.Range("B" & i) = wb1.Range("B" & i).Value
sht2.Range("C" & i) = wb1.Range("C" & i).Value
sht2.Range("D" & i) = wb1.Range("D" & i).Value

因此，在每张纸上，您都可以从wb1获得副本。另一种选择是像这样使用Offset()：

sht2.Range("A2").Offset(i - 2, 0) = wb1.Range("A" & i).Value
sht2.Range("B2").Offset(i - 2, 0) = wb1.Range("B" & i).Value
sht2.Range("C2").Offset(i - 2, 0) = wb1.Range("C" & i).Value

取决于你究竟需要什么，以及你感觉更舒服。

MSDN Offset

Answer 4

如果你要做的就是将每一行复制到一个新的表格，那么这对你有用：

Sub tgr()

    Dim wb As Workbook
    Dim SourceWS As Worksheet
    Dim Headers As Range
    Dim SourceData As Range
    Dim DataRow As Range

    Set wb = ActiveWorkbook
    Set SourceWS = wb.Sheets("Source")
    Set Headers = SourceWS.Range("B1").CurrentRegion.Resize(1)
    Set SourceData = SourceWS.Range("B2", SourceWS.Cells(SourceWS.Rows.Count, "B").End(xlUp))
    If SourceData.Row < 2 Then Exit Sub   'No data

    For Each DataRow In SourceData.Cells
        With wb.Sheets.Add(After:=wb.Sheets(wb.Sheets.Count))
            Headers.Copy
            .Range("A1").PasteSpecial xlPasteAll
            .Range("A1").PasteSpecial xlPasteColumnWidths
            DataRow.Resize(, Headers.Columns.Count).Copy .Range("A2")
        End With
    Next DataRow

    Application.CutCopyMode = False

End Sub

Answer 5

你应该采用这种方法。

The range for the code example below looks like this
Column A : Header in A1 = Country, A2:A? = Country names
Column B : Header in B1 = Name, B2:B? = Names
Column C : Header in C1 = Gender, C2:C? = F or M
Column D : Header in D1 = Birthday, D2:D? = Dates

1：在ActiveSheet上设置过滤器范围：A1是过滤器范围的左上角单元格和第一列的标题，D是过滤器范围中的最后一列。您还可以将代码名称添加到代码中，如下所示：工作表（＆＃34; Sheet1＆＃34;）。范围（＆＃34; A1：D＆＃34;＆amp; LastRow（工作表（＆＃34; Sheet1＆＃34;）））当您使用此宏时运行宏时，无需工作表处于活动状态。设置My_Range =范围（＆＃34; A1：D＆＃34;＆amp; LastRow（ActiveSheet））

2：过滤并设置过滤器字段和过滤条件：此示例过滤范围中的第一列（如果需要，更改字段）。在这种情况下，范围从A开始，因此字段1是A列，2 = B列，...... 使用＆＃34;＆lt;＆gt;荷兰＆＃34;作为标准，如果你想要相反的 My_Range.AutoFilter字段：= 1，Criteria1：=＆＃34; =荷兰＆＃34;

3：重要：此宏调用名为LastRow的函数您可以在宏下方找到此功能，将此功能与标准模块中的宏一起复制

在代码中，您可以看到四个可以使用的过滤器示例，我们在此宏中使用示例1，并在代码中评论了其他3个示例。 1：代码中的标准（=荷兰，请参阅宏下面的提示） 2：过滤ActiveCell值 3：过滤范围值（本例中为D1） 4：过滤InputBox值

Sub Copy_With_AutoFilter1()
'Note: This macro use the function LastRow
    Dim My_Range As Range
    Dim CalcMode As Long
    Dim ViewMode As Long
    Dim FilterCriteria As String
    Dim CCount As Long
    Dim WSNew As Worksheet
    Dim sheetName As String
    Dim rng As Range

    'Set filter range on ActiveSheet: A1 is the top left cell of your filter range
    'and the header of the first column, D is the last column in the filter range.
    'You can also add the sheet name to the code like this :
    'Worksheets("Sheet1").Range("A1:D" & LastRow(Worksheets("Sheet1")))
    'No need that the sheet is active then when you run the macro when you use this.
    Set My_Range = Range("A1:D" & LastRow(ActiveSheet))
    My_Range.Parent.Select

    If ActiveWorkbook.ProtectStructure = True Or _
       My_Range.Parent.ProtectContents = True Then
        MsgBox "Sorry, not working when the workbook or worksheet is protected", _
               vbOKOnly, "Copy to new worksheet"
        Exit Sub
    End If

    'Change ScreenUpdating, Calculation, EnableEvents, ....
    With Application
        CalcMode = .Calculation
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
        .EnableEvents = False
    End With
    ViewMode = ActiveWindow.View
    ActiveWindow.View = xlNormalView
    ActiveSheet.DisplayPageBreaks = False

    'Firstly, remove the AutoFilter
    My_Range.Parent.AutoFilterMode = False

    'Filter and set the filter field and the filter criteria :
    'This example filter on the first column in the range (change the field if needed)
    'In this case the range starts in A so Field 1 is column A, 2 = column B, ......
    'Use "<>Netherlands" as criteria if you want the opposite
    My_Range.AutoFilter Field:=1, Criteria1:="=Netherlands"

    'If you want to filter on a cell value you can use this, use "<>" for the opposite
    'This example uses the activecell value
    'My_Range.AutoFilter Field:=1, Criteria1:="=" & ActiveCell.Value

    'This will use the cell value from A2 as criteria
    'My_Range.AutoFilter Field:=1, Criteria1:="=" & Range("A2").Value

    ''If you want to filter on a Inputbox value use this
    'FilterCriteria = InputBox("What text do you want to filter on?", _
     '                              "Enter the filter item.")
    'My_Range.AutoFilter Field:=1, Criteria1:="=" & FilterCriteria

    'Check if there are not more then 8192 areas(limit of areas that Excel can copy)
    CCount = 0
    On Error Resume Next
    CCount = My_Range.Columns(1).SpecialCells(xlCellTypeVisible).Areas(1).Cells.Count
    On Error GoTo 0
    If CCount = 0 Then
        MsgBox "There are more than 8192 areas:" _
             & vbNewLine & "It is not possible to copy the visible data." _
             & vbNewLine & "Tip: Sort your data before you use this macro.", _
               vbOKOnly, "Copy to worksheet"
    Else
        'Add a new Worksheet
        Set WSNew = Worksheets.Add(After:=Sheets(ActiveSheet.Index))

        'Ask for the Worksheet name
        sheetName = InputBox("What is the name of the new worksheet?", _
                             "Name the New Sheet")

        On Error Resume Next
        WSNew.Name = sheetName
        If Err.Number > 0 Then
            MsgBox "Change the name of sheet : " & WSNew.Name & _
                 " manually after the macro is ready. The sheet name" & _
                 " you fill in already exists or you use characters" & _
                 " that are not allowed in a sheet name."
            Err.Clear
        End If
        On Error GoTo 0

        'Copy/paste the visible data to the new worksheet
        My_Range.Parent.AutoFilter.Range.Copy
        With WSNew.Range("A1")
            ' Paste:=8 will copy the columnwidth in Excel 2000 and higher
            ' Remove this line if you use Excel 97
            .PasteSpecial Paste:=8
            .PasteSpecial xlPasteValues
            .PasteSpecial xlPasteFormats
            Application.CutCopyMode = False
            .Select
        End With

        ' If you want to delete the rows that you copy, also use this
        ' With My_Range.Parent.AutoFilter.Range
        '     On Error Resume Next
        '     Set rng = .Offset(1, 0).Resize(.Rows.Count - 1, .Columns.Count) _
        '               .SpecialCells(xlCellTypeVisible)
        '     On Error GoTo 0
        '     If Not rng Is Nothing Then rng.EntireRow.Delete
        ' End With

    End If

    'Close AutoFilter
    My_Range.Parent.AutoFilterMode = False

    'Restore ScreenUpdating, Calculation, EnableEvents, ....
    My_Range.Parent.Select
    ActiveWindow.View = ViewMode
    If Not WSNew Is Nothing Then WSNew.Select
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = CalcMode
    End With

End Sub


Function LastRow(sh As Worksheet)
    On Error Resume Next
    LastRow = sh.Cells.Find(What:="*", _
                            After:=sh.Range("A1"), _
                            Lookat:=xlPart, _
                            LookIn:=xlValues, _
                            SearchOrder:=xlByRows, _
                            SearchDirection:=xlPrevious, _
                            MatchCase:=False).Row
    On Error GoTo 0
End Function

VBA将数据复制到带循环的单独页面

5 个答案: