填充给定起点和终点的字母数字值范围

Question

有一个三列约 9,400 行的表格，列出了字母数字代码范围的开始和结束值，以及分配给这些范围的第三个值。需要将两列范围端点更改为一列明确列出的 (1:1) 值。您能想出一种方法来自动显式列出范围内的值吗？

当前示例行：
|---r1----|---r2----|ccs|
| 0106T | 0110T | 7 |

期望的输出：
|--代码-|ccs|
| 0106T | 7 |
| 0107T | 7 |
| 0108T | 7 |
| 0109T | 7 |
| 0110T | 7 |

这存储在 MySQL 数据库和 Excel 工作簿中，但任何语言或操作方式都可以。

Answer 1

如果它仅带有“T”，这将起作用并且是您完整宏的良好基础：

Sub Alpha()
Dim WsS As Worksheet
Set WsS = Worksheets("Source")
Dim WsR As Worksheet
Set WsR = DeleteAndAddSheet("Results")

For i = 2 To WsS.Range("A" & Rows.Count).End(xlUp).Row

    For k = Val(WsS.Cells(i, 1)) To Val(WsS.Cells(i, 2))
        WsR.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0) = k & "T " & WsS.Cells(i, 3)
    Next k

Next i

End Sub

表格的有用功能：

Public Function DeleteAndAddSheet(ByVal SheetName As String) As Worksheet

For Each aShe In Sheets
    If aShe.Name <> SheetName Then
    Else
        Application.DisplayAlerts = False
        aShe.Delete
        Application.DisplayAlerts = True
        Exit For
    End If
Next aShe

Sheets.Add after:=Sheets(Sheets.Count)
Sheets(Sheets.Count).Name = SheetName

Set DeleteAndAddSheet = ThisWorkbook.Worksheets(Worksheets.Count)

End Function

Answer 2

查看R3uK提供的解决方案，Set DeleteAndAddSheet语句中的DeleteAndAddSheet函数似乎有错误。语句错误，下标超出范围错误。不确定预期的结果是否是工作表编号。 R3uK，你能澄清一下吗？ 谢谢。

Answer 3

仅供参考，这是一些示例数据和最终使用的宏。我不是程序员，并且已经达到了“足够好”的程度。非常感谢 R3uK 一路领先：

r1 | r2 |抄送
0001T | 0002T | 52
0003T | 0003T | 130
0005T | 0006T | 59
0007T | 0007T | 211
0008T | 0008T | 93
0009T | 0009T | 125
00100 | 00104 | 232
0010T | 0010T | 40
00120 | 00126 | 232
0012T | 0013T | 162
00140 | 00148 | 232
0014T | 0014T | 176
17999 | 17999 | 175
19000 | 19001 | 165
19020 | 19020 | 175
19030 | 19103 | 165
C2018 | C2018 | 243
C2019 | C2019 | 243
C2020 | C2020 | 243
C2021 | C2021 | 243
C2022 | C2022 | 243
C2023 | C2023 | 243

Public Function DeleteAndAddSheet(ByVal SheetName As String) As Worksheet

For Each aShe In Sheets
    If aShe.Name <> SheetName Then
    Else
        Application.DisplayAlerts = False
        aShe.Delete
        Application.DisplayAlerts = True
        Exit For
    End If
Next aShe

Sheets.Add after:=Sheets(Sheets.Count)
Sheets(Sheets.Count).Name = SheetName

Set DeleteAndAddSheet = ThisWorkbook.Worksheets(Worksheets.Count)

End Function

Sub Popluate_Ranges()

Dim WsS As Worksheet
Set WsS = Worksheets("Sheet1")
Dim WsR As Worksheet
Set WsR = DeleteAndAddSheet("Results")
Dim sc As Integer
Dim sr As Integer
Dim rc As Integer
Dim rr As Long
Dim rr2 As Long
Dim rc2 As Integer
Dim a As String
Dim b As String
Dim c As String
Dim v1 As String
Dim v2 As String
Dim d As String
Dim e As String
Dim f As String
Dim i As Integer

'break string into 3 parts for handling

rr = 1
rc = 1
sr = 2
sc = 1

For sr = 2 To WsS.Range("A2").End(xlDown).Row

    For sc = 1 To 2
    'write the first digit to first result column
    WsR.Cells(rr, rc) = Left(Format(WsS.Cells(sr, sc), "00000"), 1)
    rc = rc + 1
    'write the middle 3 digits to the second result column
    WsR.Cells(rr, rc) = Right(Left(Format(WsS.Cells(sr, sc), "00000"), 4), 3)
    rc = rc + 1
    'write the last digit to the third result column
    WsR.Cells(rr, rc) = Right(Format(WsS.Cells(sr, sc), "00000"), 1)
    rc = rc + 1
    Next sc

    'write ccs
    WsR.Cells(rr, rc) = WsS.Cells(sr, sc)
    rr = rr + 1
    rc = 1

Next sr
WsR.Range("B:B").NumberFormat = "000"
WsR.Range("E:E").NumberFormat = "000"

rr = 1
rc = 1
rr2 = 1
rc2 = 8

For rr = 1 To WsR.Range("A1").End(xlDown).Row
        'write/rejoin range start value

        a = WsR.Cells(rr, rc).Value
        b = WsR.Cells(rr, rc + 1).Value
        c = WsR.Cells(rr, rc + 2).Value
        WsR.Cells(rr2, rc2) = Format(a, "0") & Format(b, "000") & Format(c, "0")
        WsR.Cells(rr2, rc2 + 1) = WsR.Cells(rr, 7).Value
        rr2 = rr2 + 1

        'check if at the end of the range
        d = WsR.Cells(rr, rc + 3).Value
        e = WsR.Cells(rr, rc + 4).Value
        f = WsR.Cells(rr, rc + 5).Value


        Do Until (a = d And b = e And c = f)

                If IsNumeric(a) = False Then
                    i = a
                    i = i + 1
                    v1 = a
                    c = Right(i, 1)
                    v2 = a
                    If v1 = 9 And v2 = 0 Then
                        b = b + 1
                    End If

                ElseIf IsNumeric(c) = False Then

                    b = b + 1

                Else:
                i = c
                    i = i + 1
                    v1 = c
                    c = Right(i, 1)
                    v2 = c
                    If v1 = 9 And v2 = 0 Then
                        b = b + 1
                    End If

                End If

                WsR.Cells(rr2, rc2) = Format(a, "0") & Format(b, "000") & Format(c, "0")
                WsR.Cells(rr2, rc2 + 1) = WsR.Cells(rr, 7).Value
                'WsR.Cells(rr2, rc2 + 2) = rr
                rr2 = rr2 + 1

         Loop

Next rr
WsR.Range("H:H").NumberFormat = "00000"
WsR.Activate
Range("A1:G1").EntireColumn.Delete
End Sub