AdvancedDNA Ответов: 1

Напишите макрос для вставки данных в столбец excel на основе числового порядка

У меня есть лист Excel со столбцами данных, которые я хотел бы сохранить заблокированными и редактируемыми только макросом, содержащимся в другом листе.

Данные, которые мне нужно обновить, выглядят следующим образом: Ctrl#упорядочены в числовом порядке

Ctrl#    Note	Ctrl#	Note	Ctrl#	Note
001	     Desc1  009	    Desc9	019	    Desc19
003	     Desc3  010	    Desc10	020     Desc20
004	     Desc4  013	    Desc13	021	    Desc21



Я хочу использовать 2-й лист с двумя столбцами для ввода данных, как показано ниже, и когда будет добавлена новая строка, обновите первый лист и соответствующим образом отрегулируйте сетку. 

001	Desc1
003	Desc3
004	Desc4
009	Desc9
010	Desc10
013	Desc13
019	Desc19
020	Desc20
021	Desc21


Пример:
Если я добавлю 002 Desc2 к контрольному листу такой, что: 

001	Desc1
002 Desc2
003	Desc3
004	Desc4
009	Desc9
010	Desc10
013	Desc13
019	Desc19
020	Desc20
021	Desc21


...Я хочу, чтобы сетка регулировалась вот так

Ctrl#    Note	Ctrl#	Note	Ctrl#	Note
001	     Desc1  004	    Desc4	013	    Desc13
002	     Desc2  009	    Desc9	019     Desc19
003	     Desc3  010	    Desc10	020	    Desc20
                                021	    Desc21


Любая помощь будет оценена по достоинству.

Что я уже пробовал:

Я попытался записать макрос, но не смог настроить сетку, используя числовой порядок. Записанный макрос вставляет новые данные в указанную ячейку, а не на основе Ctrl#.

Maciej Los

Что вы пробовали? Где ты застрял?
Нет никакой возможности упорядочить ваши данные в числовом порядке, пока Ctr#не будет содержать ведущие нули...

1 Ответов

Рейтинг:
5

Maciej Los

Что ж...

Я ненавижу предоставлять готовое к использованию решение, но сегодня вечером я сделаю исключение ;)

Option Explicit

Sub SortAndExportData()
    Dim wbk As Workbook
    Dim srcwsh As Worksheet, dstwsh As Worksheet
    Dim rangeToSort As Range
    Dim i As Integer, r As Integer, c As Integer, divider As Integer
    
    'define workbook
    Set wbk = ThisWorkbook
    'define source worksheet
    Set srcwsh = wbk.Worksheets("Sheet2")
    'define range to sort
    Set rangeToSort = srcwsh.UsedRange  'or: srcwsh.Range("A1:B11")
    'sort data, threat text as numbers
    With srcwsh.Sort
        .SortFields.Clear
        'define Ctrl# header as a Key!
        .SortFields.Add Key:=rangeToSort.Cells(1, 1), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortTextAsNumbers
        .SetRange rangeToSort
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

    'define destination worksheet
    Set dstwsh = wbk.Worksheets("Sheet1")
    dstwsh.UsedRange.Delete Shift:=xlShiftUp
    'define number of rows for each column
    divider = 3
    r = 2
    c = 0
    For i = 2 To rangeToSort.Rows.Count
        'add headers
        dstwsh.Range("A1").Offset(ColumnOffset:=c) = "Ctrl#"
        dstwsh.Range("B1").Offset(ColumnOffset:=c) = "Note"
        'values
        dstwsh.Range("A" & r).Offset(ColumnOffset:=c) = rangeToSort(i, 1)
        dstwsh.Range("B" & r).Offset(ColumnOffset:=c) = rangeToSort(i, 2)
        r = r + 1
        If CInt(i - 1) Mod divider = 0 Then
            r = 2
            c = c + 2
        End If
    Next

Exit_SortAndExportData:
    On Error Resume Next
    Set wbk = Nothing
    Set dstwsh = Nothing
    Set srcwsh = Nothing
    Set rangeToSort = Nothing

End Sub


Не стесняйтесь менять его в соответствии с вашими потребностями!

AdvancedDNA

Большое вам спасибо, Мацей Лос! Это прекрасно работало с несколькими модификациями, чтобы сохранить мой заголовок.

Maciej Los

Я рад, что могу помочь.
Совет: вы можете использовать "звезды" (система голосования), чтобы сказать, насколько мой ответ был вам полезен ;)
Ура!
Мацей