Question

我正在尝试在访问表单上创建一个按钮，该按钮将复制excel文件的信息，并将其粘贴到如下所示的访问表中：

我要从中粘贴的示例excel文件是 here on this site（单击excel图标）。

问题在于excel文件数据的格式已完全关闭，它与我在Access表上设置数据标签的方式不一致。我想要做的是选择Excel数据并复制它，然后在访问中使用一个按钮，单击该按钮时，它会从剪贴板中获取信息，排列行，消除多余的空间，并排列列等，并将信息放在有序访问表。

我刚刚开始学习vba，并且几天来我一直在尝试我能想到的一切，但是都没有成功，这意味着我能够以我想要的方式将数据获取到剪贴板中，但是我无法从剪贴板中获取数据进入访问能力。请帮忙！谢谢！

我到目前为止的代码

Sub cmdCopy_Click()
Dim objData As New MSForms.DataObject

Dim strText As String
Dim i As Long
Dim j As Long
Dim k As Long
Dim m As Long
Dim ComponentNumber As Integer
Dim ComponentText As String
Dim ComponentBlock(100) As Long
Dim ComponentContent(100) As String
Dim ComponentCount As Integer
Dim ComponentStart As Long
Dim ComponentEnd As Long 
Dim ComponentLength As Integer
Dim SearchChar As String
Dim Component(100, 2) As Long
Dim LineArray(8000) As String
Dim labname As Integer
Dim TestString As String
Dim ReferenceRangeStart As Integer
Dim Position As String
Dim ColumnDatePosition(6) As Integer
Dim ColumnDateCount As Integer
Dim ComponentBlockLength As Long
Dim PreliminaryArray(10000, 10) As Variant
ComponentCount = 0
'get text from Clipboard
objData.GetFromClipboard
strText = objData.GetText()
 ' replace double empty lines with single
StrLength = Len(strText)
strText = Replace(strText, Chr(13) & Chr(10) & Chr(13) & Chr(10), Chr(13) & 
Chr(10))
For i = 10 To StrLength
If Mid(strText, i, 9) = "Component" Then
ComponentBlock(ComponentCount) = i
ComponentCount = ComponentCount + 1
i = i + 9
End If
Next i
 ' separate clipboard into component blocks
ComponentStart = 1
For i = 0 To ComponentCount - 1
ComponentContent(i) = Mid(strText, ComponentStart, ComponentBlock(i) - ComponentStart)
ComponentStart = ComponentBlock(i)
Next i
TotalBlocks = i - 1
' determine column spacing
SearchChar = Chr(13) & Chr(10)
ArrayLength = 0
For k = 0 To TotalBlocks
Next k
ComponentLength = InStr(ComponentContent(k), SearchChar) + 1
'Determine where Reference Range starts
ReferenceRangeStart = InStr(1, ComponentContent(k), "Latest")
'Determine position of each date column
ColumnDateCount = 0
For m = 0 To 6
ColumnDatePosition(m) = 0
Next m
ComponentLength = InStr(ComponentContent(k), SearchChar) + 1
'Determine where Reference Range starts
ReferenceRangeStart = InStr(1, ComponentContent(k), "Latest")
'Determine position of each date column
ColumnDateCount = 0

For i = ReferenceRangeStart + 7 To ComponentLength - 10
Position = Mid(ComponentContent(k), i, 6)
If Position Like "##/##/" Then
ColumnDatePosition(ColumnDateCount) = i
i = i + 6
ColumnDateCount = ColumnDateCount + 1
End If
If Position Like "#/##/#" Then
ColumnDatePosition(ColumnDateCount) = i
i = i + 6
ColumnDateCount = ColumnDateCount + 1
End If
If Position Like "#/#/##" Then
ColumnDatePosition(ColumnDateCount) = i
i = i + 6
ColumnDateCount = ColumnDateCount + 1
End If
If Position Like "##/#/#" Then
ColumnDatePosition(ColumnDateCount) = i
i = i + 6
ColumnDateCount = ColumnDateCount + 1
End If
   Next i
'Debug.Print ColumnDatePosition(0), ColumnDatePosition(1), ColumnDatePosition(2), ColumnDatePosition(3), ColumnDatePosition(4), ColumnDatePosition(5)
'Length of component line is ComponentLength
'Reference Range starts at ReferenceRangeStart
'ColumnDateCount indicates how many date columns of labs are present
'ColumnDatePosition(ColumnDateCount) stores the date positions
'ComponentContent(ComponentCount) represents the text block for each component block
'Mid(ComponentContent(0), ColumnDatePosition(1), 10), Mid(ComponentContent(0), ColumnDatePosition(2), 10), Mid(ComponentContent(0), ColumnDatePosition(3), 10)

LineLength = Len(ComponentContent(k)) / ComponentLength
For i = 1 To LineLength
If Mid(ComponentContent(k), (i - 1) * ComponentLength + 1, 9) <> "Component" 
And Not Asc(Mid(ComponentContent(k), (i - 1) * ComponentLength + 1, 1)) = 32 
Then
        j = 0
        Do While ColumnDatePosition(j + 1) > 0
        If Asc(Mid(ComponentContent(k), ColumnDatePosition(j) + (i - 1) * ComponentLength, 1)) <> 32 Then
            'ArrayLength,0 is component(lab name)
            PreliminaryArray(ArrayLength, 0) = Mid(ComponentContent(k), (i - 1) * ComponentLength + 1, ReferenceRangeStart - 1)
            DateLength = ColumnDatePosition(j + 1) - ColumnDatePosition(j)
            ReferenceLength = ColumnDatePosition(0) - ReferenceRangeStart
            'ArrayLength,1 is reference range
            PreliminaryArray(ArrayLength, 1) = Mid(ComponentContent(k), ReferenceRangeStart + (i - 1) * ComponentLength, ReferenceLength)
            'ArrayLength,2 is date
            PreliminaryArray(ArrayLength, 2) = Mid(ComponentContent(k), ColumnDatePosition(j), 10)
            PreliminaryArray(ArrayLength, 2) = CDate(PreliminaryArray(ArrayLength, 2))
            'ArrayLength,3 is lab value
            PreliminaryArray(ArrayLength, 3) = Mid(ComponentContent(k), ColumnDatePosition(j) + (i - 1) * ComponentLength, DateLength)
            ArrayLength = ArrayLength + 1
        End If
        j = j + 1
        Loop
        If Asc(Mid(ComponentContent(k), ColumnDatePosition(j) + (i - 1) * ComponentLength, 1)) <> 32 Then
        PreliminaryArray(ArrayLength, 0) = Mid(ComponentContent(k), (i - 1) * ComponentLength + 1, ReferenceRangeStart - 1)
        PreliminaryArray(ArrayLength, 1) = Mid(ComponentContent(k), ReferenceRangeStart + (i - 1) * ComponentLength, ColumnDatePosition(0) - ReferenceRangeStart)
        PreliminaryArray(ArrayLength, 2) = Mid(ComponentContent(k), ColumnDatePosition(j), 10)
        PreliminaryArray(ArrayLength, 2) = CDate(PreliminaryArray(ArrayLength, 2))
        PreliminaryArray(ArrayLength, 3) = Mid(ComponentContent(k), ColumnDatePosition(j) + (i - 1) * ComponentLength, ComponentLength - ColumnDatePosition(j) - 2)
        ArrayLength = ArrayLength + 1
        End If
End If

下一个我

Answer 1

更改为等距字体会显示数据已转换为4个空格分隔的列。

使用Range.TextToColumns()进行拆分，并使用WorksheetFunction.Transpose(.UsedRange.Value)进行数据转置，我们得到了一个11列乘3行的标准表。

+------------------------+--------------+-------------------+-------------------------+-----------+-----------------------+---------------------------+-----------------------------+-------------------------------+----------------------------+----------------+---------------------------+---------------------+--------------------------+-----------------------+------------------------+---------------------+----------------------+-----------------------+-------------------------+-----------------+-----------------------+-----------------+------------------------+----------------------+------------------+---------------+-------------------------+-----------------+----------------------+------------------------+-------------------+----------------------+----------------------+---------------+---------------+--------------+
|       Component        | Color, Urine | Appearance, Urine | Specific Gravity, Urine | Urine pH  | Protein Semiquant, UA | Glucose, Urine, Semiquant | Ketones, Urine, Qualitative | Bilirubin, Urine, Qualitative | Hemoglobin Pigments, Urine | Nitrite, Urine | Leukocyte Esterase, Urine | Urobilinogen, Urine | White Blood Cells, Urine | White Blood Cells, UA | Red Blood Cells, Urine | Red Blood Cells, UA | Hyaline Casts, Urine | Granular Casts, Urine | Epithelial Cells, Urine | Bacteria, Urine | Mucous Threads, Urine | Crystals, Urine | White Blood Cell Count | Red Blood Cell Count |    Hemoglobin    |  Hematocrit   | Mean Corpuscular Volume | Mean Corpus Hgb | Mean Corpus Hgb Conc | RBC Distribution Width |  Platelet Count   | Mean Platelet Volume | Nucleated RBC Number | Neutrophil %  | Lymphocytes % |  Monocyte %  |
+------------------------+--------------+-------------------+-------------------------+-----------+-----------------------+---------------------------+-----------------------------+-------------------------------+----------------------------+----------------+---------------------------+---------------------+--------------------------+-----------------------+------------------------+---------------------+----------------------+-----------------------+-------------------------+-----------------+-----------------------+-----------------+------------------------+----------------------+------------------+---------------+-------------------------+-----------------+----------------------+------------------------+-------------------+----------------------+----------------------+---------------+---------------+--------------+
| Latest Ref Rng & Units |              |                   | 1.003 - 1.030           | 4.6 - 8.0 | Negative              | Negative mg/dL            | Negative                    | Negative                      | Negative                   | Negative       | Negative                  | 0.2 - 1.0 mg/dL     | 0 - 5 /[HPF]             | 0 - 27 /uL            | 0 - 5 /[HPF]           | 0 - 27 /uL          | 0 - 1 /[LPF]         | None seen /[LPF]      | /[HPF]                  | None-few /[HPF] | None-few /[LPF]       | None-few /[HPF] | 4.50 - 11.00 K/cu mm   | 4.00 - 5.20 M/cu mm  | 12.0 - 15.0 g/dL | 36.0 - 46.0 % | 80.0 - 100.0 fL         | 26.0 - 34.0 pg  | 31.0 - 37.0 g/dL     | 11.5 - 14.5 %          | 150 - 350 K/cu mm | 9.2 - 12.7 fL        | 0.00 - 0.01 K/cu mm  | 40.0 - 70.0 % | 24.0 - 44.0 % | 2.0 - 11.0 % |
| 12/19/2016             | Yellow       | Clear             | 1.012                   | 6         | Negative              | Negative                  | Negative                    | Negative                      | Small (A)                  | Negative       | Moderate (A)              | <=1.0               | 0                        | 1                     | 1                      | 3                   | 0                    | 0                     | <1                      | None            | Rare                  | None            |                        |                      |                  |               |                         |                 |                      |                        |                   |                      |                      |               |               |              |
| 1/24/2017              |              |                   |                         |           |                       |                           |                             |                               |                            |                |                           |                     |                          |                       |                        |                     |                      |                       |                         |                 |                       |                 | 1.82 (L)               | 4.71                 | 12.6             | 39.3          | 83.4                    | 26.8            | 32.1                 | 13.1                   | 165               | 12.5                 | 0                    | 42.4          | 37.9          | 16.5 (H)     |
|                        |              |                   |                         |           |                       |                           |                             |                               |                            |                |                           |                     |                          |                       |                        |                     |                      |                       |                         |                 |                       |                 |                        |                      |                  |               |                         |                 |                      |                        |                   |                      |                      |               |               |              |
|                        |              |                   |                         |           |                       |                           |                             |                               |                            |                |                           |                     |                          |                       |                        |                     |                      |                       |                         |                 |                       |                 |                        |                      |                  |               |                         |                 |                      |                        |                   |                      |                      |               |               |              |
+------------------------+--------------+-------------------+-------------------------+-----------+-----------------------+---------------------------+-----------------------------+-------------------------------+----------------------------+----------------+---------------------------+---------------------+--------------------------+-----------------------+------------------------+---------------------+----------------------+-----------------------+-------------------------+-----------------+-----------------------+-----------------+------------------------+----------------------+------------------+---------------+-------------------------+-----------------+----------------------+------------------------+-------------------+----------------------+----------------------+---------------+---------------+--------------+

代码

Sub RealignData()
    Dim data As Variant
    With Worksheets("Sheet1")

        .UsedRange.TextToColumns Destination:=.Range("A1"), DataType:=xlFixedWidth, FieldInfo:=Array(Array(0, 1), Array(79, 1), Array(128, 1), Array(154, 1)), TrailingMinusNumbers:=True
        data = WorksheetFunction.Transpose(.UsedRange.Value)
        .UsedRange.ClearContents
        Range("A1").Resize(UBound(data), UBound(data, 2)).Value = data

    End With
End Sub

这应该使数据更易于使用。至于使其进入Access，则有更好的方法进行复制和粘贴。我建议学习如何使用Adodb.Recordset.AddNew。

如何设置按钮以添加和转换剪贴板中的数据？

1 个答案:

代码