Question

我有一个包含37行和8000列的Excel表。该表不直观，因为在列中而不是在行中发现观察。正如你所看到的，结构是这样的：类别（标题） - 条目 - 类别（作者） - 条目等等。最后，我想要一个很好的清理数据集，其中包含第1行中的类别和剩下的行。

我遇到的第一个问题是并非所有观察都包括所有类别：第1-5列不包含“资金”（F12类别名称，F13内容）。现在我设法在@Xabier的帮助下编译了我的第一个VBA代码，如果第12行不包含“Funding”，它会插入两个空白单元格并将其余部分移动到下面。我已经为所有类别行做了这个。我已经尝试了更少的观察代码，它似乎工作。

这是代码：

Sub foo()
Dim ws As Worksheet: Set ws = Sheets("Sheet2")
'declare and set your Sheet above
'lastrow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
'find the last row with data on Column A

For i = 1 To 8000 'loop from column 1 to last
    If Not ws.Cells(2, i).Value = "Title" Then 'if category is not found,
        ws.Cells(2, i).Insert Shift:=xlDown 'insert a blank cell in column i
        ws.Cells(2, i).Insert Shift:=xlDown 'again insert a second blank cell in column i
    End If
Next i

For i = 1 To 8000 'loop from column 1 to last
    If Not ws.Cells(4, i).Value = "Author" Then 'if category is not found,
        ws.Cells(4, i).Insert Shift:=xlDown 'insert a blank cell in column i
        ws.Cells(4, i).Insert Shift:=xlDown 'again insert a second blank cell in column i
    End If
Next i

For i = 1 To 8000 'loop from column 1 to last
    If Not ws.Cells(6, i).Value = "Unit" Then 'if category is not found,
        ws.Cells(6, i).Insert Shift:=xlDown 'insert a blank cell in column i
        ws.Cells(6, i).Insert Shift:=xlDown 'again insert a second blank cell in column i
    End If
Next i

For i = 1 To 8000 'loop from column 1 to last
    If Not ws.Cells(8, i).Value = "Keyword" Then 'if category is not found,
        ws.Cells(8, i).Insert Shift:=xlDown 'insert a blank cell in column i
        ws.Cells(8, i).Insert Shift:=xlDown 'again insert a second blank cell in column i
    End If
Next i

For i = 1 To 8000 'loop from column 1 to last
    If Not ws.Cells(10, i).Value = "Abstract" Then 'if category is not found,
        ws.Cells(10, i).Insert Shift:=xlDown 'insert a blank cell in column i
        ws.Cells(10, i).Insert Shift:=xlDown 'again insert a second blank cell in column i
    End If
Next i

For i = 1 To 8000 'loop from column 1 to last
    If Not ws.Cells(12, i).Value = "Funding" Then 'if category is not found,
        ws.Cells(12, i).Insert Shift:=xlDown 'insert a blank cell in column i
        ws.Cells(12, i).Insert Shift:=xlDown 'again insert a second blank cell in column i
    End If
Next i

For i = 1 To 8000 'loop from column 1 to last
    If Not ws.Cells(14, i).Value = "Source" Then 'if category is not found,
        ws.Cells(14, i).Insert Shift:=xlDown 'insert a blank cell in column i
        ws.Cells(14, i).Insert Shift:=xlDown 'again insert a second blank cell in column i
    End If
Next i

For i = 1 To 8000 'loop from column 1 to last
    If Not ws.Cells(16, i).Value = "Date" Then 'if category is not found,
        ws.Cells(16, i).Insert Shift:=xlDown 'insert a blank cell in column i
        ws.Cells(16, i).Insert Shift:=xlDown 'again insert a second blank cell in column i
    End If
Next i

For i = 1 To 8000 'loop from column 1 to last
    If Not ws.Cells(18, i).Value = "Page" Then 'if category is not found,
        ws.Cells(18, i).Insert Shift:=xlDown 'insert a blank cell in column i
        ws.Cells(18, i).Insert Shift:=xlDown 'again insert a second blank cell in column i
    End If
Next i

For i = 1 To 8000 'loop from column 1 to last
    If Not ws.Cells(20, i).Value = "ISSN" Then 'if category is not found,
        ws.Cells(20, i).Insert Shift:=xlDown 'insert a blank cell in column i
        ws.Cells(20, i).Insert Shift:=xlDown 'again insert a second blank cell in column i
    End If
Next i

For i = 1 To 8000 'loop from column 1 to last
    If Not ws.Cells(22, i).Value = "CN" Then 'if category is not found,
        ws.Cells(22, i).Insert Shift:=xlDown 'insert a blank cell in column i
        ws.Cells(22, i).Insert Shift:=xlDown 'again insert a second blank cell in column i
    End If
Next i

For i = 1 To 8000 'loop from column 1 to last
    If Not ws.Cells(24, i).Value = "Language" Then 'if category is not found,
        ws.Cells(24, i).Insert Shift:=xlDown 'insert a blank cell in column i
        ws.Cells(24, i).Insert Shift:=xlDown 'again insert a second blank cell in column i
    End If
Next i

For i = 1 To 8000 'loop from column 1 to last
    If Not ws.Cells(26, i).Value = "ClassificationNumber" Then 'if category is not found,
        ws.Cells(26, i).Insert Shift:=xlDown 'insert a blank cell in column i
        ws.Cells(26, i).Insert Shift:=xlDown 'again insert a second blank cell in column i
    End If
Next i

For i = 1 To 8000 'loop from column 1 to last
    If Not ws.Cells(28, i).Value = "DOI" Then 'if category is not found,
        ws.Cells(28, i).Insert Shift:=xlDown 'insert a blank cell in column i
        ws.Cells(28, i).Insert Shift:=xlDown 'again insert a second blank cell in column i
    End If
Next i

For i = 1 To 8000 'loop from column 1 to last
    If Not ws.Cells(30, i).Value = "TimesCited" Then 'if category is not found,
        ws.Cells(30, i).Insert Shift:=xlDown 'insert a blank cell in column i
        ws.Cells(30, i).Insert Shift:=xlDown 'again insert a second blank cell in column i
    End If
Next i

For i = 1 To 8000 'loop from column 1 to last
    If Not ws.Cells(32, i).Value = "Citesothers" Then 'if category is not found,
        ws.Cells(32, i).Insert Shift:=xlDown 'insert a blank cell in column i
        ws.Cells(32, i).Insert Shift:=xlDown 'again insert a second blank cell in column i
    End If
Next i

For i = 1 To 8000 'loop from column 1 to last
    If Not ws.Cells(34, i).Value = "CitedReferences" Then 'if category is not found,
        ws.Cells(34, i).Insert Shift:=xlDown 'insert a blank cell in column i
        ws.Cells(34, i).Insert Shift:=xlDown 'again insert a second blank cell in column i
    End If
Next i

For i = 1 To 8000 'loop from column 1 to last
    If Not ws.Cells(36, i).Value = "Citedby" Then 'if category is not found,
        ws.Cells(36, i).Insert Shift:=xlDown 'insert a blank cell in column i
        ws.Cells(36, i).Insert Shift:=xlDown 'again insert a second blank cell in column i
    End If
Next i

End Sub

但是，使用更大的数据集，Excel最终会在运行一段时间后崩溃。虽然我有一个Windows 10 64位版本，但我只有32位的Excel，因为我需要使用我大学的计算机。现在我怀疑它可能与此有关。但是，大学不希望将程序重新安装为64位版本。无论如何，我可以通过使代码更容易，或将其分解成碎片来解决我的问题？我非常缺乏经验，所以我不确定是否如此，甚至是如何工作的。任何帮助赞赏！

编辑：尝试使用数组完成它：

Sub dd()
Dim firstRow As Long
Dim lastRow As Long

firstRow = 1
lastRow = 37

Dim tableArray() As Variant
Dim k As Long

With dataWorkbook.Worksheets("Sheet2")

tableArray = .Range(.Cells(firstRow, 1), _
                            .Cells(lastRow, 8000)).Value

For k = 1 To 8000 'for each column in the table

If tableArray(4, k) = "Author" Then
Else
    ws.Cells(4, k).Insert Shift:=xlDown 'insert a blank cell in column i
    ws.Cells(4, k).Insert Shift:=xlDown 'again insert a second blank cell in column i

End If

If tableArray(6, k) = "Keyword" Then
Else
    ws.Cells(6, k).Insert Shift:=xlDown 'insert a blank cell in column i
    ws.Cells(6, k).Insert Shift:=xlDown 'again insert a second blank cell in column i

End If

Dim worksheetRange As Range
Set worksheetRange = .Range(.Cells(firstRow, 1), _
                            .Cells(lastRow, 8000))
worksheetRange.Value = tableArray

End With

End Sub

编辑：将我的数据加载到数组中

 Sub dynamicMultidimensionalArray()
    Dim Chinese() As Variant
    Dim Dimension1 As Long, dimension2 As Long

    Dimension1 = Range("A1").End(xlDown).Row + 1
    dimension2 = Range("A1").End(xlToRight).Column
    ReDim Chinese(0 To Dimension1, 0 To dimension2)




    For Dimension1 = LBound(Chinese, 1) To UBound(Chinese, 1)
        For dimension2 = LBound(Chinese, 2) To UBound(Chinese, 2)
            Chinese(Dimension1, dimension2) = Range("A1").Offset(Dimension1, dimension2).Value
        Next dimension2
    Next Dimension1

Answer 1

我没有仔细查看您的代码，但您似乎正在检查cell.value并正在迭代8000列。关于这一点的经验法则是通过vba直接迭代工作表中的单元格是非常缓慢和低效的。您必须先将数据加载到数组中，如下所示：

Dim firstRow As Long
Dim lastRow As Long

firstRow = 1
lastRow = 37

Dim tableArray() As Variant
Dim k As Long

With dataWorkbook.Worksheets("YOUR_SHEET_NAME")

tableArray = .Range(.Cells(firstRow, 1), _
                            .Cells(lastRow, 8000)).value

然后你在vba中执行所有迭代：over array：

For k = 1 To 8000 'for each column in the table

If tableArray(4, k) = "Author" Then
   ...
Else
   'edit the existing array: tableArray, not a worksheet!
End If

Next

然后，在您完成编辑tableArray并拥有最终版本后，您可以一次性将其加载到工作表中：

Dim worksheetRange As Range
Set worksheetRange = .Range(.Cells(firstRow, 1), _
                            .Cells(lastRow, 8000))
worksheetRange.value = tableArray

End With

如果您有任何问题，请随时提出。我自己一直在处理大桌子，所以我知道痛苦。

Excel表对于VBA代码来说太大了 - 简化代码？

1 个答案: