在 excel visual basic 中根据样本的测试和 ID 粘贴数据
Pasting Data for samples based on their Test and ID in excel visual basic
我有一个数据 sheet，样本 ID、测试类型和测试结果都在三个单独的列（A、B、C）中。
一些样本 ID 被多次列出，因为它们都接受了不同的测试。
Sample IDs, Test Type, Test Results 三栏在Sheet1。
我需要（在 sheet 2 上）将样本 ID 粘贴到 A 列下方（每个只有一次迭代），并将测试类型粘贴到第 1 行。到目前为止，我已经设法完成了这两件事，但是我我不确定如何将单个测试结果数据粘贴到 sheet 上的正确位置，例如：样本 1 是 Y 值，测试类型 1 是 Y 轴，因为缺乏正确的解释方法。
我只需要它来复制测试结果并根据样本 ID 和测试类型将它们粘贴到另一个 sheet.
每次使用此工作簿时，样本 ID 和测试类型都会发生变化。
我对 VBA 非常陌生（只有几个星期的经验）所以不要把我的代码烤得太硬哈哈。
这是我目前粘贴样本 ID 和测试类型的内容：
Sub Transpose1()
Dim sht1 As Worksheet
Dim sht2 As Worksheet
Dim wkb1 As Workbook
Set wkb1 = ThisWorkbook
Set sht1 = wkb1.Sheets("Raw Data")
'Where the data is stored
Set sht2 = wkb1.Sheets("TestResultTable")
'This is where everything is to be pasted
sht2.Range("B2:Z4200").ClearContents
sht1.Range("A1:A4200").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=sht2.Range( _
"A1"), Unique:=True
'Sample IDs pasted with only one iteration of each sample
sht1.Range("B1:B4200").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=sht2.Range( _
"B2"), Unique:=True
'Test Type pasted on sheet2 to be copied again and pasted horizontally
sht2.Range("B3:B4200").Copy
sht2.Range("B1").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
Application.CutCopyMode = False
sht2.Range("B2:B4200").ClearContents
'The Test results are in sht1 column C
End Sub
同样，这只是我必须在 Sheet2 上将样本 ID 粘贴到 A 列下并将测试类型粘贴到 sheet2 上第 1 行的代码。
非常感谢
结果不会这样组织，A、B、C、D 等只是为了隐藏专有信息
Screenshot of example data and format
基本VBA 枢轴
Sub BasicPivot()
' s - Source (read from)
Const sName As String = "Raw Data"
Const sFirstCellAddress As String = "A1"
Const srCol As Long = 1
Const scCol As Long = 2
Const svCol As Long = 3
' d - Destination (write to)
Const dName As String = "TestResultTable"
Const dFirstCellAddress As String = "A1"
Const dFirstColumnHeader As String = ""
' Workbook
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
' 1.) Write the source data to an array.
' a) Reference the source worksheet.
Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
' b) Reference the source range.
Dim srg As Range: Set srg = sws.Range(sFirstCellAddress).CurrentRegion
Dim srCount As Long: srCount = srg.Rows.Count
' c.) Write the values from the source range to an array.
Dim sData As Variant: sData = srg.Value
' 2.) Use dictionaries to get the unique row and column labels.
' a) Define the row dictionary.
Dim rDict As Object: Set rDict = CreateObject("Scripting.Dictionary")
rDict.CompareMode = vbTextCompare
Dim dr As Long: dr = 1
' b) Define the column dictionary.
Dim cDict As Object: Set cDict = CreateObject("Scripting.Dictionary")
cDict.CompareMode = vbTextCompare
Dim dc As Long: dc = 1
' c) Loop through the rows of the array and write the unique
' row and column labels to the dictionaries.
Dim Key As Variant
Dim sr As Long
For sr = 2 To srCount
Key = sData(sr, srCol)
If Not rDict.Exists(Key) Then
dr = dr + 1
rDict(Key) = dr
End If
Key = sData(sr, scCol)
If Not cDict.Exists(Key) Then
dc = dc + 1
cDict(Key) = dc
End If
Next sr
' 3.) Write the result to an array.
' a) Define the array.
Dim drCount As Long: drCount = rDict.Count + 1
Dim dcCount As Long: dcCount = cDict.Count + 1
Dim dData As Variant: ReDim dData(1 To drCount, 1 To dcCount)
' b) Write the first column header.
Dim dfHeader As String
If Len(dFirstColumnHeader) = 0 Then
dfHeader = CStr(srg.Cells(1).Value)
Else
dfHeader = dFirstColumnHeader
End If
dData(1, 1) = dfHeader
' c) Write the row labels.
dr = 1
For Each Key In rDict.Keys
dr = dr + 1
dData(dr, 1) = Key
Next Key
' d) Write the column labels.
dc = 1
For Each Key In cDict.Keys
dc = dc + 1
dData(1, dc) = Key
Next Key
' e) Write the values.
For sr = 2 To srCount
dData(rDict(sData(sr, srCol)), cDict(sData(sr, scCol))) _
= sData(sr, svCol)
Next sr
' 4.) Write the results to the destination.
' a) Reference the destination worksheet.
Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
' b) Clear its cells.
dws.UsedRange.Clear
' c) Write the values from the array to the destination range.
With dws.Range(dFirstCellAddress).Resize(, dcCount)
.Resize(drCount).Value = dData
End With
' 5.) Inform.
MsgBox "Pivot has finished.", vbInformation
End Sub
我有一个数据 sheet，样本 ID、测试类型和测试结果都在三个单独的列（A、B、C）中。 一些样本 ID 被多次列出，因为它们都接受了不同的测试。 Sample IDs, Test Type, Test Results 三栏在Sheet1。 我需要（在 sheet 2 上）将样本 ID 粘贴到 A 列下方（每个只有一次迭代），并将测试类型粘贴到第 1 行。到目前为止，我已经设法完成了这两件事，但是我我不确定如何将单个测试结果数据粘贴到 sheet 上的正确位置，例如：样本 1 是 Y 值，测试类型 1 是 Y 轴，因为缺乏正确的解释方法。 我只需要它来复制测试结果并根据样本 ID 和测试类型将它们粘贴到另一个 sheet.
每次使用此工作簿时，样本 ID 和测试类型都会发生变化。 我对 VBA 非常陌生（只有几个星期的经验）所以不要把我的代码烤得太硬哈哈。
这是我目前粘贴样本 ID 和测试类型的内容：
Sub Transpose1()
Dim sht1 As Worksheet
Dim sht2 As Worksheet
Dim wkb1 As Workbook
Set wkb1 = ThisWorkbook
Set sht1 = wkb1.Sheets("Raw Data")
'Where the data is stored
Set sht2 = wkb1.Sheets("TestResultTable")
'This is where everything is to be pasted
sht2.Range("B2:Z4200").ClearContents
sht1.Range("A1:A4200").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=sht2.Range( _
"A1"), Unique:=True
'Sample IDs pasted with only one iteration of each sample
sht1.Range("B1:B4200").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=sht2.Range( _
"B2"), Unique:=True
'Test Type pasted on sheet2 to be copied again and pasted horizontally
sht2.Range("B3:B4200").Copy
sht2.Range("B1").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
Application.CutCopyMode = False
sht2.Range("B2:B4200").ClearContents
'The Test results are in sht1 column C
End Sub
同样，这只是我必须在 Sheet2 上将样本 ID 粘贴到 A 列下并将测试类型粘贴到 sheet2 上第 1 行的代码。
非常感谢
结果不会这样组织，A、B、C、D 等只是为了隐藏专有信息 Screenshot of example data and format
基本VBA 枢轴
Sub BasicPivot()
' s - Source (read from)
Const sName As String = "Raw Data"
Const sFirstCellAddress As String = "A1"
Const srCol As Long = 1
Const scCol As Long = 2
Const svCol As Long = 3
' d - Destination (write to)
Const dName As String = "TestResultTable"
Const dFirstCellAddress As String = "A1"
Const dFirstColumnHeader As String = ""
' Workbook
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
' 1.) Write the source data to an array.
' a) Reference the source worksheet.
Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
' b) Reference the source range.
Dim srg As Range: Set srg = sws.Range(sFirstCellAddress).CurrentRegion
Dim srCount As Long: srCount = srg.Rows.Count
' c.) Write the values from the source range to an array.
Dim sData As Variant: sData = srg.Value
' 2.) Use dictionaries to get the unique row and column labels.
' a) Define the row dictionary.
Dim rDict As Object: Set rDict = CreateObject("Scripting.Dictionary")
rDict.CompareMode = vbTextCompare
Dim dr As Long: dr = 1
' b) Define the column dictionary.
Dim cDict As Object: Set cDict = CreateObject("Scripting.Dictionary")
cDict.CompareMode = vbTextCompare
Dim dc As Long: dc = 1
' c) Loop through the rows of the array and write the unique
' row and column labels to the dictionaries.
Dim Key As Variant
Dim sr As Long
For sr = 2 To srCount
Key = sData(sr, srCol)
If Not rDict.Exists(Key) Then
dr = dr + 1
rDict(Key) = dr
End If
Key = sData(sr, scCol)
If Not cDict.Exists(Key) Then
dc = dc + 1
cDict(Key) = dc
End If
Next sr
' 3.) Write the result to an array.
' a) Define the array.
Dim drCount As Long: drCount = rDict.Count + 1
Dim dcCount As Long: dcCount = cDict.Count + 1
Dim dData As Variant: ReDim dData(1 To drCount, 1 To dcCount)
' b) Write the first column header.
Dim dfHeader As String
If Len(dFirstColumnHeader) = 0 Then
dfHeader = CStr(srg.Cells(1).Value)
Else
dfHeader = dFirstColumnHeader
End If
dData(1, 1) = dfHeader
' c) Write the row labels.
dr = 1
For Each Key In rDict.Keys
dr = dr + 1
dData(dr, 1) = Key
Next Key
' d) Write the column labels.
dc = 1
For Each Key In cDict.Keys
dc = dc + 1
dData(1, dc) = Key
Next Key
' e) Write the values.
For sr = 2 To srCount
dData(rDict(sData(sr, srCol)), cDict(sData(sr, scCol))) _
= sData(sr, svCol)
Next sr
' 4.) Write the results to the destination.
' a) Reference the destination worksheet.
Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
' b) Clear its cells.
dws.UsedRange.Clear
' c) Write the values from the array to the destination range.
With dws.Range(dFirstCellAddress).Resize(, dcCount)
.Resize(drCount).Value = dData
End With
' 5.) Inform.
MsgBox "Pivot has finished.", vbInformation
End Sub