Question

有一个包含三列和~9,400行的表，列出了代码的字母数字范围的起始值和结束值，以及分配给范围的第三个值。希望将两列范围端点更改为明确列出的（1：1）值的单列。您能想到一种方法来自动显示范围内的值吗？

当前示例行：
| --- R1 ---- | --- R2 ---- | CCS |
| 0106T | 0110T | 7 |

期望的输出：
| --code- | 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 | ccs
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

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

3 个答案: