Добавление пропущеных строк - Microsoft Office Excel

zenner · 05.12.2023, 09:53

Добрый день! У меня есть база данных телефонов и ихняя позиция в корзине. Но в этой таблице есть дырки, например нету Корзина 1, Плата 1, Порт 6. Можно ли с помощью функции или макроса добавить пропущенные строки чтобы они выглядели например так: Пропусщенный Parked 1 6 Корзина 1. Каждая плата имеет 48 портов и в каждой корзине 14 плат. СПАСИБО!!!

Elixi · 05.12.2023, 22:45

Цитата:

Сообщение от zenner

Каждая плата имеет 48 портов и в каждой корзине 14 плат.

zenner, в вашем файле в корзине ''Корзина 3'' плат не 14 а 7. Вы хотели сказать что недостающих 7 плат по 48 портов с пустыми ячейками ''Номер'' нужно в таблицу добавить?

Elixi · 06.12.2023, 10:01

Код:

Sub TEST()
'   ДЛЯ ФАЙЛА КОТОРЫЙ ВЫ ПРИКРЕПИЛИ
'   ЗАПУСКАЙТЕ ПРИ АКТИВНОМ ЛИСТЕ С ДАННЫМИ

    Dim Data(), Korz(), Dict As Object
    Dim Rw&, RwL&, Co&, Key$, Val$, KO&, PL&, PO&
    Const RwF& = 2, CoF& = 1, CoL& = 5
    Set Dict = CreateObject("Scripting.Dictionary")
    
    ' ДАННЫЕ В МАССИВ
    RwL = Cells(Rows.Count, 3).End(xlUp).Row
    Data = Range(Cells(RwF, CoF), Cells(RwL, CoL))
    
    ' СОРТИРОВКА ДАННЫХ
    Data = BubbleSort(Data)
    
    ' ПОЛУЧЕНИЕ УНИКАЛЬНЫХ ДАННЫХ СТОЛБЦА КОРЗИНА
    For Rw = LBound(Data, 1) To UBound(Data, 1)
        If Not Dict.exists(Data(Rw, 5)) Then
            Dict.Add Data(Rw, 5), 0
        End If
    Next Rw

    ' УНИКАЛЬНЫЕ ДАННЫЕ КОРЗИНА В МАССИВ
    ReDim Korz(1 To Dict.Count)
    For Rw = 0 To Dict.Count - 1
        Korz(Rw + 1) = Dict.Keys()(Rw)
    Next Rw
    
    ' ОЧИСТКА СЛОВАРЯ
    Dict.RemoveAll

    ' НАПОЛНЕНИЕ СЛОВАРЯ ДАННЫМИ
    For Rw = LBound(Data, 1) To UBound(Data, 1)
        Key = Data(Rw, 5) & "," _
            & Format(Data(Rw, 3), "00") & "," _
            & Format(Data(Rw, 4), "00")
        If Not Dict.exists(Key) Then
            Val = Data(Rw, 1) & "," & Data(Rw, 2)
            Dict.Add Key, Val
        End If
    Next Rw
    
    ' ДОПОЛНЕНИЕ СЛОВАРЯ НЕДОСТАЮЩИМИ ДАННЫМИ ПOРТ И ПЛАТА
    ' ВСЕ ЖЕЛАЕМЫЕ КOРЗИНЫ ВЗЯТЫ ИЗ СУЩЕСТВУЙУЩЕЙ ТАБЛИЦИ
    For KO = LBound(Korz) To UBound(Korz)
    For PL = 1 To 14
    For PO = 1 To 48
        Key = Korz(KO) & "," _
            & Format(PL, "00") & "," _
            & Format(PO, "00")
        If Not Dict.exists(Key) Then
            Val = ","
            Dict.Add Key, Val
        End If
    Next PO
    Next PL
    Next KO
    
    ' ДАННЫЕ ИЗ СЛОВАРЯ В МАССИВ
    ReDim Data(1 To Dict.Count, 1 To 5)
    
    For Rw = 0 To Dict.Count - 1
        Data(Rw + 1, 5) = Split(Dict.Keys()(Rw), ",")(0)
        Data(Rw + 1, 3) = Split(Dict.Keys()(Rw), ",")(1)
        Data(Rw + 1, 4) = Split(Dict.Keys()(Rw), ",")(2)
        Data(Rw + 1, 1) = Split(Dict.Items()(Rw), ",")(0)
        Data(Rw + 1, 2) = Split(Dict.Items()(Rw), ",")(1)
    Next Rw
    
    ' СОРТИРОВКА ДАННЫХ
    Data = BubbleSort(Data)

    ' ДАННЫЕ В НОВЫЙ ЛИСТ
    ActiveSheet.Copy Before:=ActiveSheet
    ActiveSheet.Name = Format(Date, "yyyy-mm-dd") & "_" & _
                        Format(Time, "hh-mm-ss")
    ActiveSheet.UsedRange.Offset(1, 0).Clear
    Cells(2, 1).Resize( _
            UBound(Data, 1) - LBound(Data, 1) + 1, _
            UBound(Data, 2) - LBound(Data, 2) + 1) = Data

    ' ОЧИСТКА
    Dict.RemoveAll: ReDim Data(0): ReDim Korz(0)

End Sub


Function BubbleSort(Arr As Variant) As Variant
'   Сортируем массив ...
' Если здесь чтo-тo тoрмoзит, тo этo именнo эта
' сoртирoвка. Для тестирoвки ее хватит. Хoтите
' пoбыстрее, сделайте себе другую.

    Dim Check As Boolean, i%, j%, tmp As Variant
    
    Do Until Check
        Check = True
        For i = LBound(Arr, 1) + 1 To UBound(Arr, 1) - 1
            '   ... по столбцам, по очереди (5, 3, 4):
            If Arr(i, 5) > Arr(i + 1, 5) _
                Or Arr(i, 5) = Arr(i + 1, 5) _
                    And Arr(i, 3) > Arr(i + 1, 3) _
                Or Arr(i, 5) = Arr(i + 1, 5) _
                    And Arr(i, 3) = Arr(i + 1, 3) _
                    And Arr(i, 4) > Arr(i + 1, 4) _
                Then
                For j = LBound(Arr, 2) To UBound(Arr, 2)
                    tmp = Arr(i, j)
                    Arr(i, j) = Arr(i + 1, j)
                    Arr(i + 1, j) = tmp
                Next
                Check = False
            End If
        Next
    Loop
    BubbleSort = Arr
End Function

zenner · 07.12.2023, 07:14

Цитата:

Сообщение от Elixi

Код:

Sub TEST()
'   ДЛЯ ФАЙЛА КОТОРЫЙ ВЫ ПРИКРЕПИЛИ
'   ЗАПУСКАЙТЕ ПРИ АКТИВНОМ ЛИСТЕ С ДАННЫМИ

    Dim Data(), Korz(), Dict As Object
    Dim Rw&, RwL&, Co&, Key$, Val$, KO&, PL&, PO&
    Const RwF& = 2, CoF& = 1, CoL& = 5
    Set Dict = CreateObject("Scripting.Dictionary")
    
    ' ДАННЫЕ В МАССИВ
    RwL = Cells(Rows.Count, 3).End(xlUp).Row
    Data = Range(Cells(RwF, CoF), Cells(RwL, CoL))
    
    ' СОРТИРОВКА ДАННЫХ
    Data = BubbleSort(Data)
    
    ' ПОЛУЧЕНИЕ УНИКАЛЬНЫХ ДАННЫХ СТОЛБЦА КОРЗИНА
    For Rw = LBound(Data, 1) To UBound(Data, 1)
        If Not Dict.exists(Data(Rw, 5)) Then
            Dict.Add Data(Rw, 5), 0
        End If
    Next Rw

    ' УНИКАЛЬНЫЕ ДАННЫЕ КОРЗИНА В МАССИВ
    ReDim Korz(1 To Dict.Count)
    For Rw = 0 To Dict.Count - 1
        Korz(Rw + 1) = Dict.Keys()(Rw)
    Next Rw
    
    ' ОЧИСТКА СЛОВАРЯ
    Dict.RemoveAll

    ' НАПОЛНЕНИЕ СЛОВАРЯ ДАННЫМИ
    For Rw = LBound(Data, 1) To UBound(Data, 1)
        Key = Data(Rw, 5) & "," _
            & Format(Data(Rw, 3), "00") & "," _
            & Format(Data(Rw, 4), "00")
        If Not Dict.exists(Key) Then
            Val = Data(Rw, 1) & "," & Data(Rw, 2)
            Dict.Add Key, Val
        End If
    Next Rw
    
    ' ДОПОЛНЕНИЕ СЛОВАРЯ НЕДОСТАЮЩИМИ ДАННЫМИ ПOРТ И ПЛАТА
    ' ВСЕ ЖЕЛАЕМЫЕ КOРЗИНЫ ВЗЯТЫ ИЗ СУЩЕСТВУЙУЩЕЙ ТАБЛИЦИ
    For KO = LBound(Korz) To UBound(Korz)
    For PL = 1 To 14
    For PO = 1 To 48
        Key = Korz(KO) & "," _
            & Format(PL, "00") & "," _
            & Format(PO, "00")
        If Not Dict.exists(Key) Then
            Val = ","
            Dict.Add Key, Val
        End If
    Next PO
    Next PL
    Next KO
    
    ' ДАННЫЕ ИЗ СЛОВАРЯ В МАССИВ
    ReDim Data(1 To Dict.Count, 1 To 5)
    
    For Rw = 0 To Dict.Count - 1
        Data(Rw + 1, 5) = Split(Dict.Keys()(Rw), ",")(0)
        Data(Rw + 1, 3) = Split(Dict.Keys()(Rw), ",")(1)
        Data(Rw + 1, 4) = Split(Dict.Keys()(Rw), ",")(2)
        Data(Rw + 1, 1) = Split(Dict.Items()(Rw), ",")(0)
        Data(Rw + 1, 2) = Split(Dict.Items()(Rw), ",")(1)
    Next Rw
    
    ' СОРТИРОВКА ДАННЫХ
    Data = BubbleSort(Data)

    ' ДАННЫЕ В НОВЫЙ ЛИСТ
    ActiveSheet.Copy Before:=ActiveSheet
    ActiveSheet.Name = Format(Date, "yyyy-mm-dd") & "_" & _
                        Format(Time, "hh-mm-ss")
    ActiveSheet.UsedRange.Offset(1, 0).Clear
    Cells(2, 1).Resize( _
            UBound(Data, 1) - LBound(Data, 1) + 1, _
            UBound(Data, 2) - LBound(Data, 2) + 1) = Data

    ' ОЧИСТКА
    Dict.RemoveAll: ReDim Data(0): ReDim Korz(0)

End Sub


Function BubbleSort(Arr As Variant) As Variant
'   Сортируем массив ...
' Если здесь чтo-тo тoрмoзит, тo этo именнo эта
' сoртирoвка. Для тестирoвки ее хватит. Хoтите
' пoбыстрее, сделайте себе другую.

    Dim Check As Boolean, i%, j%, tmp As Variant
    
    Do Until Check
        Check = True
        For i = LBound(Arr, 1) + 1 To UBound(Arr, 1) - 1
            '   ... по столбцам, по очереди (5, 3, 4):
            If Arr(i, 5) > Arr(i + 1, 5) _
                Or Arr(i, 5) = Arr(i + 1, 5) _
                    And Arr(i, 3) > Arr(i + 1, 3) _
                Or Arr(i, 5) = Arr(i + 1, 5) _
                    And Arr(i, 3) = Arr(i + 1, 3) _
                    And Arr(i, 4) > Arr(i + 1, 4) _
                Then
                For j = LBound(Arr, 2) To UBound(Arr, 2)
                    tmp = Arr(i, j)
                    Arr(i, j) = Arr(i + 1, j)
                    Arr(i + 1, j) = tmp
                Next
                Check = False
            End If
        Next
    Loop
    BubbleSort = Arr
End Function

Спасибо Вам Большое!!! Буду пробовать...

Опции темы	Поиск в этой теме
Версия для печати Отправить по электронной почте	Поиск в этой теме: Расширенный поиск

Похожие темы
Тема	Автор	Раздел	Ответов	Последнее сообщение
Добавление строк в таблицу	UbeiBobra	Microsoft Office Excel	13	26.01.2016 14:46
Добавление строк в StringGrid	Asblue	Помощь студентам	2	22.10.2010 23:21
Добавление строк в таблицу с вставкой в них текста и чередованием фона строк	Centurion2xx6	Microsoft Office Word	9	30.03.2010 11:00
Добавление строк	Atevss	Microsoft Office Excel	8	10.03.2010 05:15
ДОбавление строк из БД	Kveldulv	Microsoft Office Excel	2	09.02.2010 15:52