Question

我想使用Excel中的基本数据创建一些Web应用程序但是数据的结构需要调整

有人可以帮我更改此表吗？
A B C D
E F G H
I J K L
M N O P

到

A B
A C
A D
E F
E G
E H
我J
I K
我L
M N
M O
M P

或类似的东西，我已经尝试使用此宏

http://www.get-digital-help.com/2012/05/07/vba-macro-normalize-data/

它可以处理数百个数据，但是当我尝试在超过12000个数据上使用它时，它将停止工作

Answer 1

尝试一下：

'select a cell in your data before running
Sub DoIt()

    Dim data, n As Long, r As Long, c As Long
    Dim result(), i As Long

    With Selection.CurrentRegion
        data = .Value
        n = .Cells.Count
    End With

    ReDim result(1 To n, 1 To 2)
    i = 0

    For r = 1 To UBound(data, 1)
        For c = 2 To UBound(data, 2)
            If Len(data(r, c)) > 0 Then
                i = i + 1
                result(i, 1) = data(r, 1)
                result(i, 2) = data(r, c)
            End If
        Next c
    Next r

    'adjust output location to suit
    ActiveSheet.Range("G1").Resize(i, 2) = result

End Sub

输入/输出：

Answer 2

您指向的宏的问题在第

行中

Rng.Offset(r, 0).Value

至少对我来说，例如，当我删除对范围的引用并将其替换为对第一个单元格的引用时，例如

WS1.Range("A1").Offset(r, 0).Value

它极大地加快了宏的运行速度=我在13000行上运行了该宏，并仅用此调整就使用了链接中的宏在10秒内完成了该操作。

具有以下更改的完整宏：

Sub NormalizeData()
Dim Rng As Range
Dim WS As Worksheet

Application.Calculation = xlCalculationManual
On Error Resume Next
Set Rng = Application.InputBox(Prompt:="Select a range to normalize data" _
, Title:="Select a range", Default:=ActiveCell.Address, Type:=8)
On Error GoTo 0

If Rng Is Nothing Then
Else
    Application.ScreenUpdating = False
    Set WS1 = ActiveSheet                       '<==== added this line
    Set WS = Sheets.Add
    i = 0
    For r = 0 To Rng.Rows.Count - 1             '<==== offset start changed to 0
        For c = 1 To Rng.Columns.Count - 1
            WS.Range("A1").Offset(i, 0) = WS1.Range("A1").Offset(r, 0).Value '<==== change
            WS.Range("A1").Offset(i, 1) = WS1.Range("A1").Offset(r, c).Value '<==== change
            i = i + 1
        Next c
        Application.StatusBar = r
    Next r
    WS.Range("A:C").EntireColumn.AutoFit
    Application.StatusBar = False
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
End If
End Sub

Excel更改表数据以规范化数据

2 个答案: