excel - VBA尝试检查列中的值以及是否将另一个单元格值复制到新列

Question

我在一张表中有一张数据表，我希望对其进行一些调整。我有一个名为“S/R”的列，其中包含两个值之一[Serving OR Returning]。如果该值正在服务，我想将值从名为“1stServeX”的列复制到我添加的新列中，我称为“Server 1st Serve X”。

我已经编写了下面的代码，但我开始绊倒自己，也无法完成最后一部分。我是一个新手，所以一直在使用我之前获得的其他代码片段来尝试将它拼凑在一起，这就是我需要一些帮助的原因。

如果我能做到这一点，那么我可以简单地对所有“Returner”选项以及我需要拆分的所有其他列重复它。

提前感谢您提供的任何帮助。

Public Sub splitServerCoordinates()
    'Set a constant for the title of the Server Column
    Const HEADER_SR As String = "S/R"
    
    Dim ws As Worksheet
    Set ws = Sheets("transition")
    Dim strSearch As String
    Dim aCell As Range
    Dim COL_SR As Long
    Dim COL_TARGET As Long
    Dim COL_CURRENT As Long

    'Find the Column Numbers of the columns we are looking for
    strSearch = "S/R"

    Set aCell = ws.Rows(1).Find(What:=strSearch, LookIn:=xlValues, _
    LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
    MatchCase:=False, SearchFormat:=False)

    If Not aCell Is Nothing Then
        COL_SR = aCell.Column
    End If
    
    strSearch = "1stServeX"

    Set aCell = ws.Rows(1).Find(What:=strSearch, LookIn:=xlValues, _
    LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
    MatchCase:=False, SearchFormat:=False)

    If Not aCell Is Nothing Then
        COL_CURRENT = aCell.Column
    End If
    
    strSearch = "Server 1st Serve X"

    Set aCell = ws.Rows(1).Find(What:=strSearch, LookIn:=xlValues, _
    LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
    MatchCase:=False, SearchFormat:=False)

    If Not aCell Is Nothing Then
        COL_TARGET = aCell.Column
    End If
    
    Dim theUsedRange As Range
    Dim SRRange As Range
    Dim aPlayer As Range
    Dim serving As String
    Dim returning As String
    Dim theCounter As Long
    Dim theSequence As Long
    
    ws.Select
    
    ' clear out the Target column and add the header again
    Set theUsedRange = ActiveSheet.UsedRange
    Intersect(theUsedRange, Range(Columns(COL_TARGET), Columns(COL_TARGET))).ClearContents
    Columns(COL_SR).Range("A1").Value = HEADER_SR
    
    ' reset the used range just in case
    Set theUsedRange = ActiveSheet.UsedRange
    
    ' Get the used range for the S/R column
    Set SRRange = Intersect(theUsedRange, Columns(COL_SR))
    
    'Set value to compare to
    serving = "Serving"
    
    ' Loop through the S/R column
    For Each aPlayer In SRRange
        ' ignore the header row
        If aPlayer <> HEADER_SR Then
            ' if we are serving then copy the value from COL_CURRENT to COL_TARGET
            If aPlayer = serving Then
                    aPlayer.Offset(-1, COL_TARGET - COL_).Value = STUCK - HERE
            End If
        End If
    Next aPlayer
End Sub

标签： excelvba

Answer 1

一些重构以提取列标题位置部分，以及其他一些调整。未经测试，但应该能让你到达那里。

Public Sub splitServerCoordinates()
    
    Dim ws As Worksheet, c As Range
    Dim COL_SR As Long
    Dim COL_TARGET As Long
    Dim COL_CURRENT As Long

    Set ws = Sheets("transition")
    
    'Find the Column Numbers of the columns we are looking for
    COL_SR = HeaderColumnNumber(ws.Rows(1), "S/R")
    COL_CURRENT = HeaderColumnNumber(ws.Rows(1), "1stServeX")
    COL_TARGET = HeaderColumnNumber(ws.Rows(1), "Server 1st Serve X", True) 'add if not found
    
    'exit if missing any required columns
    If COL_SR = 0 Or COL_CURRENT = 0 Then
        MsgBox "Missing 'S/R' and/or '1stServeX' !"
        Exit Sub
    End If
    
    'reset target column
    ws.Columns(COL_TARGET).ClearContents
    ws.Cells(1, COL_TARGET).Value = "Server 1st Serve X"
    
    'loop rows
    For Each c In ws.Range(ws.Cells(2, COL_SR), ws.Cells(ws.Rows.Count, COL_SR).End(xlUp)).Cells
        If c.Value = "Serving" Then
            ws.Cells(c.Row, COL_TARGET).Value = ws.Cells(c.Row, COL_CURRENT).Value
        End If
    Next c
    
End Sub

'Find a header position on a row, with option to add it if not found
'  Returns zero if header is not found and option to add was not set
Function HeaderColumnNumber(rng As Range, hdr As String, _
                            Optional AddIfMissing As Boolean = False) As Long
    Dim f As Range
    Set rng = rng.Cells(1).EntireRow 'only want a full row to look in
    Set f = rng.Find(What:=hdr, LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, _
                    SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
    If Not f Is Nothing Then
        HeaderColumnNumber = f.Column 'found: return column
    Else
        'not found: do we add it, or return zero?
        If AddIfMissing Then
            With rng.Cells(rng.Cells.Count).End(xlToLeft).Offset(0, 1)
                .Value = hdr
                HeaderColumnNumber = .Column
            End With
        Else
            HeaderColumnNumber = 0
        End If
    End If
End Function