Question

我们有一个Excel表格，其中包含列标题MIC和版本。工作表Sheet：

SCRNHYF1                SCRNRBF1                SCRNEBF1            
MIC Version Lower Limit Upper Limit MIC Version Lower Limit Upper Limit MIC Version Lower Limit Upper Limit
50015357    1   95  100 50015357    1   95  100 50015359    1   90  100
50015358    1   0   100 50015358    1   0   100 50015360    1   0   100
50014016    3   95  100 50014016    3   95  100 50014016    1   90  100
50010606    2   0   100 50010606    2   0   100 50010606    15  0   100
50000779    3   95  100 50000779    3   95  100 50000779    16  90  100
50010608    2   0   100 50010608    2   0   100 50010608    15  0   100
50150795    1   95  100 50150795    1   95  100 50150795    2   90  100
50150796    1   0   100 50150796    1   0   100 50150796    2   0   100

我希望VBA代码重新排列sheet1到sheet2中的数据，如下所示。请注意：我们在sheet1中多次重复这些MIC和Version标题。 Sheet 2中：

RoS MIC Ver
SCRNHYF1    50015357    1
SCRNHYF1    50015358    1
SCRNHYF1    50014016    3
SCRNHYF1    50010606    2
SCRNHYF1    50000779    3
SCRNHYF1    50010608    2
SCRNHYF1    50150795    1
SCRNHYF1    50150796    1
SCRNRBF1    50015357    1
SCRNRBF1    50015358    1
SCRNRBF1    50014016    3
SCRNRBF1    50010606    2
SCRNRBF1    50000779    3
SCRNRBF1    50010608    2
SCRNRBF1    50150795    1
SCRNRBF1    50150796    1
SCRNEBF1    50015359    1
SCRNEBF1    50015360    1
SCRNEBF1    50014016    1
SCRNEBF1    50010606    15
SCRNEBF1    50000779    16
SCRNEBF1    50010608    15
SCRNEBF1    50150795    2
SCRNEBF1    50150796    2

我的代码到目前为止......这是行不通的..

Sub CopyRng()

Dim WS1 As Worksheet
Dim WS2 As Worksheet
Dim Rng As Range
Dim Col As Long

On Error Resume Next    

Set WS1 = Sheets("Sheet1")
Set WS2 = Sheets("Sheet2")

Set Rng = WS1.Range("E1:E25")    

With WS2

    Col = Application.WorksheetFunction.Match(WS1.Range("E1").Value, .Rows("1:1"), False)
'Writes the values to the last empty cell from the bottom of the column:
    .Cells(.Rows.count, Col).End(xlUp).Offset(1, 0).Resize(Rng.Rows.count).Value = Rng.Value


End With

End Sub

Answer 1

您需要处理Match()失败的情况：我更喜欢删除.Worksheetfunction并测试返回值以查看它是否是错误。

Sub CopyRng()

Dim WS1 As Worksheet
Dim WS2 As Worksheet
Dim Rng As Range
Dim Col 

Set WS1 = Sheets("Sheet1")
Set WS2 = Sheets("Sheet2")

Set Rng = WS1.Range("E1:E25")    

With WS2

    Col = Application.Match(WS1.Range("E1").Value, .Rows("1:1"), False)
    If Not IsError(Col) Then
         'Writes the values to the last empty cell from the bottom of the column:
         .Cells(.Rows.count, Col).End(xlUp).Offset(1, 0). _
                       Resize(Rng.Rows.count).Value = Rng.Value

    Else
         msgbox "Not found!"
    End If

End With

End Sub

用于根据列标题传输值的代码

1 个答案: