VBA数据抽取

Question

我正在尝试使用excel中的数据填充数据库(最初来自PDF)。数据存在于excel中的一列中，例如

Event Date:
02/02/02
Location:
UK
Event:
Fire
Event Date:
03/03/03
Location:
US
Cause:
Hurricane

我创建了一个虚拟矩阵来保存数据，然后从其中搜索并提取所需的信息。

然而，问题出现了，因为并非所有的数据条目都遵循相同的格式。

因此，当填充数据库时，它是这样的。

Date...................Location.................Cause..................Event 
02/02/02.............UK.........................Hurricane..............Fire
03/03/03.............US.........................Flood...................Fire
04/04/04.............France..............................................Structural Damage
05/05/05.............Germany............................................Fire

然而，信息并不对应于正确的数据等，因为它只是从上到下填充。

我需要信息以这样的方式呈现；

Date.............Location........Cause......................Event
02/02/02........UK..........................................Fire
03/03/03........US...............Hurricane..................Fire
04/04/04........France..........Flood.......................Structural Damage
05/05/05........Germany......................................Fire

我曾尝试使用下面的代码提取数据，但只设法提取了信息，而没有按要求的顺序进行排序。在提取数据时，有没有更好的方法将数据分配到数组中？

我当前的代码：

Private Sub Workbook_SheetBeforeDoubleClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean)

Dim pd(100000, 100)
Dim rpd(10000, 100)
Dim c As Integer
Dim npd As Variant

rpd(1, 1) = "Loss Number"
rpd(1, 2) = "Event Date"
rpd(1, 3) = "Country"
rpd(1, 4) = "Location"
rpd(1, 5) = "Event"
rpd(1, 6) = "Cause"
rpd(1, 7) = "Unit Type"
rpd(1, 8) = "Equipment Type"
rpd(1, 9) = "Materials"
rpd(1, 10) = "Fatalities"
rpd(1, 11) = "Injuries"
rpd(1, 12) = "Duration"
rpd(1, 13) = "Evacuated"
rpd(1, 14) = "Plant Status"
rpd(1, 15) = "Interruption"
rpd(1, 16) = "Description"


c = 1
cr = 1
npd = 1

LastRow = ThisWorkbook.Sheets("PDF Input Sheet").UsedRange.Rows.count
Lastcol = ThisWorkbook.Sheets("PDF Input Sheet").UsedRange.Columns.count

'Collect data for virtual matrix
Do Until npd = LastRow
    For c = 1 To Lastcol
        pd(npd, c) = Sheets("PDF Input Sheet").Cells(npd, c)
    Next c
    npd = npd + 1
Loop

'Extract loss number data
R = 1
cr = 1

Do Until R = npd
If pd(R, 1) = "Loss Number:" Then
    If pd(R + 1, 1) <> "" Then LossNumber = pd(R + 1, 1)

    cr = cr + 1

    rpd(cr, 1) = LossNumber

End If

R = R + 1

Loop

'Extract event date information
R = 1
cr = 1

Do Until R = npd
If pd(R, 1) = "Event Date:" Then
    If pd(R + 1, 1) <> "" Then EveDate = pd(R + 1, 1)

    cr = cr + 1

    rpd(cr, 2) = EveDate

End If

R = R + 1

Loop

'Extract country data
R = 1
cr = 1

Do Until R = npd
If pd(R, 1) = "Country:" Then
    If pd(R + 1, 1) <> "" Then Country = pd(R + 1, 1)

    cr = cr + 1

    rpd(cr, 3) = Country

End If

R = R + 1

Loop

'Extract location data
R = 1
cr = 1

Do Until R = npd
If pd(R, 1) = "Location:" Then
    If pd(R + 1, 1) <> "" Then Location = pd(R + 1, 1)

    cr = cr + 1

    rpd(cr, 4) = Location

End If

R = R + 1

Loop

'Extract event data
R = 1
cr = 1

Do Until R = npd

If pd(R, 1) = "Event:" Then
    If pd(R + 1, 1) <> "" Then Even = pd(R + 1, 1)

    cr = cr + 1

    rpd(cr, 5) = Even


End If

R = R + 1

Loop





Sheets("Accident Database").Activate
Sheets("Accident Database").Columns("A:IV").ClearContents
For R = 1 To 200
    For c = 1 To 16
    Sheets("Accident Database").Cells(R, c) = rpd(R, c)
    Next c
Next R

'Range("A1:IV4000").Sort _
'Key1:=Range("B1"), Header:=xlYes

Sheets("Accident Database").Columns("A:IV").AutoFit




End Sub

Answer 1

不是一个答案，但我想指出的是，您不需要循环来将范围读入数组！

 dim r() as variant
 r = range(cells(firstRow, firstCol) , cells((lastRow, lastCol))
 'or
 r = range("B2:f20")

就能达到目的，而且速度更快。