如何在VBA

Question

我的数据列中包含描述和ID代码（粗体字符）：

BBA-34.009876

典型的美国饮食的有害影响。

定期回收的美国人数量。

学生在社交媒体上使用的时间。

本科生和研究生的平均大学债务。

有多少公立学校削减了艺术课程。

高中运动员多久会在大学课程中取得成功。

普通的公立学校午餐有多健康。

未通过州标准化考试的低社会经济学生人数。

CCV-09.89765

一个美丽的夏日早晨在树林里。

电影，卡通或书中的角色。

这个星球上最令人恐惧的地方。

你想要的个性。

寒假的最佳去处。

某个国家的节日庆典。

最近的博物馆里最有趣的艺术品。

描述你最喜欢的季节。

FFG-890.786543

你上学的第一天。

你最喜欢的美食。

降落伞跳跃的经验。

你小时候遇到的人的记忆。

理想的学习伙伴。

人类活动造成的环境退化。

R-34.896543

你生命中最糟糕的d255 34。

做作业的最佳地点。

学习外语的经验。

选择大学和未来的职业。

你最喜欢的野营地点。

上面的数据集是一个例子，ID代码之间可能有50-2000个描述。我的问题是你如何从描述中拆分ID代码，这些代码位于不同的行但是在同一列中，并且仅将ID代码粘贴到单独的列中但在同一行中？这也必须是动态的而不是静态输入。此外，ID代码每次都没有相同的模式。

这是我一直在使用的VBA代码，是的，这是VBA中的Unifier样式代码。

Sub Unifier()
    Dim cell As Range
    Dim x As Integer
    Dim x2 As Integer
    Dim s As String
    Dim e As String
    Dim e2 As String
    Dim e3 As String
    Dim e4 As String
    Dim e5 As String
    Dim e6 As String
    Dim e7 As String
    Dim form As String





    s = Sheets("CostOS").Range("L2").Value 'Pulls 0
    x = Sheets("CostOS").Range("A" & Rows.Count).End(xlUp).Row 'Task Code Count
    x2 = Sheets("CostOS").Range("C" & Rows.Count).End(xlUp).Row 'Item Code
    x3 = Sheets("CostOS").Range("D" & Rows.Count).End(xlUp).Row 'Item Description Count
    x4 = Sheets("CostOS").Range("G" & Rows.Count).End(xlUp).Row 'UM Count
    x5 = Sheets("CostOS").Range("F" & Rows.Count).End(xlUp).Row 'Unit Rate Count
    x6 = Sheets("CostOS").Range("E" & Rows.Count).End(xlUp).Row 'Quantity Count
    x7 = Sheets("CostOS").Range("H" & Rows.Count).End(xlUp).Row 'CBS Count
    e = Sheets("CostOS").Range("L2").Value 'Approved by
    e2 = Sheets("CostOS").Range("L3").Value 'Estimate Type
    e3 = Sheets("CostOS").Range("L4").Value 'Estimate Number
    e4 = Sheets("CostOS").Range("L5").Value 'Estimator
    e5 = Sheets("CostOS").Range("L6").Value 'Approval Date
    e6 = Sheets("CostOS").Range("L7").Value 'Project Number
    e7 = Sheets("CostOS").Range("L8").Value 'Effective Date
    e8 = Sheets("CostOS").Range("V4").Value 'Task Code Prefix

    **'ID Code
    Sheets("CostOS").Range("D2:D" & x).Select
    Set cell = Sheets("CostOS").Range("A2:A" & x)
    For Each cell In cell
          If cell.Value = " " Then
             cell.Offset(0, 3).Value = Range("D2:D" & x)
          End If      
    Next**
    'Task Code, Prefix & H or D logic
    Sheets("CostOS").Range("A2:A" & x).Copy
    Sheets("EST template").Range("C3").PasteSpecial xlPasteValues
    'H or D
    For Each cell In Sheets("EST template").Range("C3:C" & x)
        If cell.Value = "" Then
            cell.Offset(0, -2).Value = "H"
        Else
            cell.Offset(0, -2).Value = "D"
        End If
    Next
    Sheets("CostOS").Range("M3").Select 'Filldown Task Prefix
    Selection.AutoFill Destination:=Range("M3:M" & x7), Type:=xlFillDefault
    For Each cell In Sheets("EST template").Range("M3:Q" & x7)
    Next
    Sheets("CostOS").Range("N2").Select 'Filldown Milepost Prefix
    Selection.AutoFill Destination:=Range("N2:N" & x7), Type:=xlFillDefault
    For Each cell In Sheets("EST template").Range("N2:Q" & x7)
    Next
    Sheets("CostOS").Range("O2").Select 'Filldown Milepost Number
    Selection.AutoFill Destination:=Range("O2:O" & x7), Type:=xlFillDefault
    For Each cell In Sheets("EST template").Range("O2:O" & x7)
    Next
    'CBS & Approval Date
    Sheets("CostOS").Range("Q3").Select 'Removes end of CBS code
    Selection.AutoFill Destination:=Range("Q3:Q" & x7), Type:=xlFillDefault
    Sheets("CostOS").Range("T3").Select 'Fills down the vlookup
    Selection.AutoFill Destination:=Range("T3:T" & x7), Type:=xlFillDefault
    Sheets("CostOS").Range("T2:T" & x).Copy
    Sheets("EST template").Range("N3").PasteSpecial xlPasteValues
    For Each cell In Sheets("EST template").Range("N3:N" & x)
        If cell.Text = "" Then
            cell.Value = e5
        End If    
    Next
    'Item Code
    Sheets("CostOS").Range("C2:C" & x).Copy
    Sheets("EST template").Range("G3").PasteSpecial xlPasteValues
    For Each cell In Sheets("EST template").Range("G3:G" & x2)

    Next
     'Estimate number
    Set cell = Sheets("EST template").Range("A3:A" & x)
    For Each cell In cell
        If cell.Value <> "D" Then
             cell.Offset(0, 6).Value = e3
        End If
    Next
    'Effective Date
    Set cell = Sheets("EST template").Range("A3:A" & x)
    For Each cell In cell
        If cell.Value <> "D" Then
            cell.Offset(0, 8).Value = e7
        End If
    Next
    'Task Code Prefix
    Set cell = Sheets("EST template").Range("A3:A" & x)
    For Each cell In cell
        If cell.Value <> "D" Then
            cell.Offset(0, 9).Value = e8
        End If
    Next
    'Quantity & Estimator
    Sheets("CostOS").Range("E2:E" & x).Copy
    Sheets("EST template").Range("K3").PasteSpecial xlPasteValues
    For Each cell In Sheets("EST template").Range("K3:K" & x6)
        If cell.Value = "" Then
            cell.Value = e4
        End If
    Next
    'Unit of Measure & Approved by
    Sheets("CostOS").Range("G2:G" & x4).Copy
    Sheets("EST template").Range("M3").PasteSpecial xlPasteValues
    For Each cell In Sheets("EST template").Range("M3:M" & x4)
        If cell.Value = "" Then
            cell.Value = e
        End If
    Next
    'Unit Cost & Estimate Type
    Sheets("CostOS").Range("F2:F" & x5).Copy
    Sheets("EST template").Range("L3").PasteSpecial xlPasteValues
    For Each cell In Sheets("EST template").Range("L3:L" & x5)
        If cell.Value = "" Then
            cell.Value = e2
        End If
    Next
    'Project Code
    For Each cell In Sheets("EST template").Range("C3:C" & x)
        If cell.Value = "" Then
            cell.Offset(0, -1).Value = e6
        Else
            cell.Offset(0, -1).Value = "Estimate Details"
        End If
    Next
    'Source
    For Each cell In Sheets("EST template").Range("C3:C" & x)
        If cell.Value = "" Then
            cell.Offset(0, 2).Value = "RailDOCS"
        Else
            cell.Offset(0, 2).Value = ""
        End If
    Next
    'Item Description
    Sheets("CostOS").Range("D3:D" & x3).Copy
    Sheets("EST template").Range("I4").PasteSpecial xlPasteValues
    For Each cell In Sheets("EST template").Range("I4:I" & x3)

    Next
    'Short Description & Task Prefix
    Sheets("Est template").Select
    Sheets("Est template").Range("J4").Select
    With ActiveCell
        .Formula = "=LEFT(I4,50)"
    End With
    Selection.AutoFill Destination:=Range("J4:J" & x3), Type:=xlFillDefault
    For Each cell In Sheets("EST template").Range("J4:J" & x3)
    Next
    CutCopyMode = False
    End Sub

粗体部分是我遇到的麻烦，其他一切都在起作用。

Answer 1

看起来所有ID代码都使用连字符。如果没有描述，则可以在InStr（）中使用测试。如果连字符不存在，则此函数将返回0（这将是您的描述）。

InStr(1, [Range Value], "-")

如果这不起作用，所有描述似乎也以句号结束。第二个测试可能是：

If Right([Range Value], 1) = "." Then ...

编辑：添加我如何使用测试。

我会像这样使用测试：

Sub SplitCodesFromDescriptions()
    Dim strCode As String
    Dim rngValues, rng As Range

    Set rngValues = Range("A1:A2500")

    For Each rng In rngValues

        If rng.Value = "" Then Exit Sub

        If InStr(1, rng.Value, "-") > 0 Then
            strCode = rng.Value
        Else
            rng.Offset(0, 1).Value = strCode
        End If

    Next
End Sub

*注意 - 我个人喜欢定义范围。可能存在Excel认为第100行中存在数据的问题。

Answer 2

您可以使用Like运算符来测试模式

Sub TestLikePattern()
    Dim x As Long

    For x = 1 To Range("A" & Rows.Count).End(xlUp).Row
        If Cells(x, 1) Like "*[A-Z][-]#*[.]#*" Then Cells(x, 2) = True
    Next

End Sub