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

I have an Excel table with 37 rows and 8000 columns. The table is not intuitive in that an observation is found in a column, rather than a row. As you can see, the structure is like this: Category (Title) - Entry - Category (Author)- Entry etc. etc.. Eventually, I want a nice cleaned up data-set which has categories in row 1 and observations in the remaining rows.

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

The first problem I had is that not all observations include all categories: Columns 1-5 do not contain "Funding" (F12 category name, F13 content). Now I managed to compile my very first VBA code with the help of @Xabier, which inserts two blank cells and shifts the rest below if for instance row 12 does not contain "Funding". I have done this for all category lines.I have tried the code on fewer observations and it seemed to be working.

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

This is the code:

这是代码：

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

However, with the bigger dataset, Excel eventually crashes, after running a while. While I have a Windows 10 64 Bit version, I only have Excel with 32 bit, as I need to work with my university's computer. Now I suspect that it might have something to do with that. However, the university does not want to reinstall the programm as 64 bit version. Is there anyway in which I can fix my problem through making the code easier, or breaking it up into pieces? I am very inexperienced, so I am not sure whether and if so how that would even work. Any help appreciated!

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

Edit: Trying to get it done with arrays:

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

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

Edit: Loading my data into an array

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

 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

1 个解决方案

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

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

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

End With