如何设置一个按钮来添加和转换剪贴板中的数据？
Posted
技术标签:
【中文标题】如何设置一个按钮来添加和转换剪贴板中的数据？【英文标题】：How can I set up a button to add & transform data from the clipboard? 【发布时间】：2018-07-18 20:20:05 【问题描述】：我正在尝试在访问表单上创建一个按钮，该按钮将复制 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
下一个
【问题讨论】：
分享你迄今为止尝试过的代码。 “没有成功”是什么意思 - 错误消息，错误结果，没有任何反应？您为调试做了哪些努力？您需要描述具体问题，而不仅仅是发布代码询问“出了什么问题”。查看此站点的代码以获取示例accessmvp.com/KDSnell/EXCEL_MainPage.htm 使用上面的代码，我能够以我想要的方式将数据获取到剪贴板，但我不知道如何将其从剪贴板获取到我的访问表中。 【参考方案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。
【讨论】：
以上是关于如何设置一个按钮来添加和转换剪贴板中的数据？的主要内容，如果未能解决你的问题，请参考以下文章
如何获取复制到剪贴板的数据值并将其设置为android studio中的另一个值