Question

我有一个类似于以下内容的电子表格：

Name       Title        ID
Person 1    Title 1     1
Person 2    Title 2     11
Person 3    Title 3     111
Person 4    Title 4     1111
Person 5    Title 5     12
Person 6    Title 6     121
Person 7    Title 7     1211
Person 8    Title 8     1212
Person 9    Title 9     122
Person 10   Title 10    13
Person 11   Title 11    131
Person 12   Title 12    1311
Person 13   Title 13    1312
Person 14   Title 14    13121
Person 15   Title 15    1313
Person 16   Title 16    132
Person 17   Title 17    1321
Person 18   Title 18    14
Person 19   Title 19    15
Person 20   Title 20    151
Person 21   Title 21    1512

我想遍历“ID”列中的每个单元格。如果列包含值，则将整行复制到新工作表。

这是棘手的部分：

 - The first number will always start with 1. 
 - I want the script to search "ID" for 1 + another single digit (10,11,12,13...). 
   For all cells that match the criteria copy that row to a new sheet. 
 - When that is done, now search for 11 + another single digit (111,112,113,114...). 
 - When that is done, now search for 12 + another digit (121,122,123,124...)

这应该继续下去：

Search "ID" for:    Finds all:
    19              191, 192, 193, 194...
    124            1241, 1242, 1243, 1244...
    1111            11111, 11112, 11113, 11114, 11115...
    1127           11271, 11272, 11273, 11274... 
    12345           123451, 123452, 123453, 123454, 123455...

“+另一个数字”前面的前面数字决定了它应该进入哪个表格。

 - If search for 1 + another single digit - these should all go on a single sheet.
 - If searching for 11 + another single digit - these should go on a single sheet.
 - If search for 1234 + another single digit - these should go on a single sheet.
 - So on and so forth.

Answer 1

我意识到我应该在询问之前发布我的尝试。无论如何，我想出了如何做到这一点。我是VBA的新手，但这很有效：

Set mainSht = Worksheets("Sheet1")  ' Copy From this sheet

'Find the last row with data in specified column.
LR = mainSht.Cells(Rows.Count, "F").End(xlUp).Row

Set LRange = mainSht.Range("F2:F" & LR)

'Find max number in the range
max = Application.WorksheetFunction.max(LRange)

'Look at every cell in cpecified column
For Each Cell In LRange
 For i = 1 To max

    cIndex = CStr(i)

    If Cell.Value Like "1" + cIndex + "?" Then    'check to See if C equals value                                       
        sheetName = "1" + cIndex

        'Check if worksheet exists
        Set wsCheck = Nothing
        On Error Resume Next
        Set wsCheck = ActiveWorkbook.Worksheets(sheetName)
        On Error GoTo 0

        'If worksheet does not exist, create new
        If wsCheck Is Nothing Then
            Worksheets.Add(After:=ActiveWorkbook.Sheets(ActiveWorkbook.Sheets.Count)).Name = sheetName
        End If

Set Pastesheet = Worksheets(sheetName)  ' Paste to this sheet
            Cell.EntireRow.Copy  ' Copy the row
            Pastesheet.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValuesAndNumberFormats
    End If
    Next

Next Cell  ' Now we check the next cell in chosen column

遍历列中的单元格，如果包含条件，则将行复制到新工作表

1 个答案: