创建一个正确过滤数据并将其放在另一个工作表上的宏

Question

我有一个以奇怪的方式排序的大型数据集，如图所示：

这是我目前的数据

这就是我希望它像

所以主要是我想要做两件事，首先我要剪切显示数据的另外两列，然后将它们粘贴到第一列下面，但仅限于第一周，然后对数据进行排序，宏记录没有＆由于几个星期真的是几个月，因此工作得很好，因此每个月的天数变化，因此每列的高度变化。

我的想法是使用while循环滚动第一列（第一列显示＆＃34; Day＆＃34;，对于每个非数字条目（比如第一个不大于零的输入），以及然后切掉整个三个块阵列并将其粘贴到其他地方，比如一张名为Week＆＃34; n＆＃34;的新表，给出了它的第n周。

然后正确地命令这个数组，复制第一个数组下面的两个右边的块，然后按天和小时对它们进行排序。

这是我想要为一周的每个数据时段做的，但我并不是很精通vba的语法来实现这一点，大多数时候我不知道如何以这种方式对数组进行排序一旦将它们复制到新工作表中，如果我不添加新工作表而是将其重新格式化，我也不知道该怎么做。

欢迎任何帮助。

Answer 1

考虑到您的数据是按照以下图片设置的......

将以下代码放在标准模块上，例如Module1 ......

Sub TransformWeekData()
Dim sws As Worksheet, dws As Worksheet
Dim lr As Long, dlr As Long, i As Long
Dim Rng As Range

Application.ScreenUpdating = False

Set sws = Sheets("Sheet1")  'Source data sheet
lr = sws.Cells(Rows.Count, 1).End(xlUp).Row

On Error Resume Next
Set dws = Sheets("Combined Data")    'Output Sheet
dws.Cells.Clear
On Error GoTo 0

If dws Is Nothing Then
    Set dws = Sheets.Add(after:=sws)
    dws.Name = "Combined Data"
End If

On Error Resume Next
For Each Rng In sws.Range("A2:A" & lr).SpecialCells(xlCellTypeConstants, 1).Areas
    If dws.Range("A1").Value = "" Then
            dlr = 1
    Else
        dlr = dws.Range("A" & Rows.Count).End(3)(2).Row
    End If
    dws.Range("A" & dlr).Value = Rng.Cells(1).Offset(-2, 0).Value
    dws.Range("A" & dlr + 1 & ":C" & dlr + 1).Value = Array("Day", "Amount", "Hour")
    For i = 1 To 9 Step 3
        dlr = dws.Range("A" & Rows.Count).End(3)(2).Row
        Rng.Offset(, i - 1).Resize(Rng.Cells.Count, 3).Copy dws.Range("A" & dlr)
    Next i
Next Rng

dlr = dws.Range("A" & Rows.Count).End(xlUp).Row

For Each Rng In dws.Range("A2:A" & dlr).SpecialCells(xlCellTypeConstants, 1).Areas
    Rng.Resize(Rng.Cells.Count, 3).Sort key1:=Rng.Cells(1), order1:=xlAscending, key2:=Rng.Cells(1, 3), order2:=xlAscending, Header:=xlNo
Next Rng
Application.ScreenUpdating = True
End Sub

如果工作簿中不存在所需格式的数据，则上面的代码将插入名为Combined Data的工作表，如下图所示...

您可以根据自己的要求更改输出表的名称。