Question

我是VBA的新手，我通过在Google中搜索以创建脚本进行了很多尝试，最后在这里寻求帮助。需要帮助，以便根据9月1日至9月30日的excel中的条件将数据从主数据复制到多张工作表中。从主数据复制基于行数列名称的值。i有一个包含数据的主表，并且需要为每个月生成报告。根据9月1日的Rownum = 1条件创建多个工作表，依此类推。

Ex:-

Rownum = 1  for Sep 1
Rownum = 2  for Sep 2
Rownum = 3  for Sep 3
Rownum = 4  for Sep 4
Rownum = 5  for Sep 5
.
.
Rownum = 29  for Sep 29
Rownum = 30  for Sep 30

我需要根据条件创建多张工作表，直到从Master Sheet完成9月30日为止。

样本数据

MasterSheet     
Date    Value   RowNums
8/31/2018 9:45  0   1
8/31/2018 10:35 0   1
9/1/2018 6:15   3   1
9/1/2018 9:45   0   2
9/1/2018 10:35  0   2
9/2/2018 4:45   8   2
9/2/2018 5:35   32  2
9/2/2018 6:15   3   2
9/2/2018 9:15   0   3
9/2/2018 11:15  0   3
9/3/2018 5:35   65  3
9/3/2018 6:15   36  3
9/3/2018 9:15   8   4
9/4/2018 6:25   0   4

OutPut

SheetName   1-Sep   
Date    Value   RowNums
8/31/2018 9:45  0   1
8/31/2018 10:35 0   1
9/1/2018 6:15   3   1
SheetName   2-Sep   
Date    Value   RowNums
9/1/2018 9:45   0   2
9/1/2018 10:35  0   2
9/2/2018 4:45   8   2
9/2/2018 5:35   32  2
9/2/2018 6:15   3   2
SheetName   3-Sep   
Date    Value   RowNums
9/2/2018 9:15   0   3
9/2/2018 11:15  0   3
9/3/2018 5:35   65  3
9/3/2018 6:15   36  3
SheetName   4-Sep   
Date    Value   RowNums
9/3/2018 9:15   8   4
9/4/2018 6:25   0   4

谢谢。

Option Explicit

Sub AddSheets()
    Dim siteCount As Integer
    Dim i As Integer
    Dim site_i As Worksheet

    Dim ws As Worksheet
    Set ws = ThisWorkbook.Sheets("MasterSheet")

    Dim r As Long, endRow as Long, pasteRowIndex As Long
    ' endRow = Cells(Rows.Count, "C").End(xlUp).Row

    siteCount = 3

    For i = 1 To siteCount
        Set site_i = Sheets.Add(after:=Sheets(Worksheets.Count))
        site_i.Name = "Sep " & CStr(i)
    Next i
    Sheets.FillAcrossSheets ws.Range("1:1")

    Sheets("MasterSheet").Select
    endRow = Cells(Rows.Count, "C").End(xlUp).Row
    pasteRowIndex = 2
    For r = 2 To endRow

        If Cells(r, Columns("C").Column).Value = 1 Then

            Rows(r).Select
            Selection.Copy

            Sheets("Sep 1").Select
            Rows(pasteRowIndex).Select
            ActiveSheet.Paste

            pasteRowIndex = pasteRowIndex + 1
            Sheets("MasterSheet").Select 
        End If
    Next r

End Sub

Answer 1

这应该为您提供正确的方向。没有错误检查，我假设如果您运行两次，您将收到一个错误，因为工作表已经存在。

无论如何都是一个好的开始。

Sub UsingCollection()
    Dim cUnique As Collection
    Dim Rng As Range
    Dim Cell As Range
    Dim sh As Worksheet
    Dim vNum As Variant, s As String
    Dim LstRw As Long, cRng As Range, C As Range, ws As Worksheet

    Set sh = ThisWorkbook.Sheets("Sheet1")

    With sh
        Set Rng = .Range("A2:A" & .Cells(.Rows.Count, "A").End(xlUp).Row)
        Set cUnique = New Collection
        LstRw = .Cells(.Rows.Count, "A").End(xlUp).Row
        Set Rng = .Range("A2:A" & LstRw)
        On Error Resume Next
        For Each Cell In Rng.Cells
            cUnique.Add Cell.Value, CStr(Cell.Value)
        Next Cell
        On Error GoTo 0

        For Each vNum In cUnique

            s = Format(vNum, "MM-DD-YY")
            Set ws = Sheets.Add
            ws.Name = s

            For Each C In Rng.Cells
                If C = vNum Then
                    .Range(.Cells(C.Row, "A"), .Cells(C.Row, "D")).Copy ws.Cells(ws.Rows.Count, "A").End(xlUp).Offset(1)
                End If
            Next C
        Next vNum
    End With

End Sub

根据9月1日至9月30日的条件，将数据从主数据复制到多张纸上

1 个答案: