Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1
RSS
Доработка макроса Redesigner, игнорировать пустые значения
 
#1
28.02.2024 19:04:33
Добрый день.

Есть у меня макрос "Redesigner" который преобразовывает двумерную таблицу (вкладка "база") в одномерный массив (вкладка "результат").

Принцип макроса прост: Выделяем нужный двумерный массив, запускаем макрос, вводим в окошках количество строк с заголовками ( в примере "1") и количество столбцов с заголовками (в примере "1") - и макрос преобразовывает данные.

Всё бы круто, но макрос преобразовывает все данные, и пустые и не пустые ( вкладка "результат", ячейки С1, С2, С3, С4, С6, С7 и т.д., а нужно что бы пустые значения игнорировал. Вариант с преобразованием и удалением пустых после преобразования - не подходит. т.к. ексель не позволяет вставить такое количество строк и макрос выдаёт ошибку: в оригинальном рабочем файле в двумерной таблице 6000 столбцов и 450 строк,  что на выходе даст 2.7 миллиона строк, чего ексель не поддерживает, хотя фактических значений которые должны остаться в одномерном массиве - около 15000.

На вкладке "желаемый результат" показал как макрос должен работать.

Буду благодарен за помощь.  
 
 
 
#2
28.02.2024 20:28:42
Liameerf Здравствуйте Может так будет
Код
Sub Redesigner()
    Dim i As Long
    Dim hc As Integer, hr As Integer
    Dim ns As Worksheet
     
    hr = InputBox("Строк")
    hc = InputBox("Столбцов")
     
    Application.ScreenUpdating = False
     
    i = 1
    Set inpdata = Selection
    Set ns = Worksheets.Add
     
    For r = (hr + 1) To inpdata.Rows.Count
        For c = (hc + 1) To inpdata.Columns.Count
        If inpdata.Cells(r, c) <> "" Then
            For j = 1 To hc
                ns.Cells(i, j) = inpdata.Cells(r, j)
            Next j
             
            For k = 1 To hr
                ns.Cells(i, j + k - 1) = inpdata.Cells(k, c)
            Next k
             
            ns.Cells(i, j + k - 1) = inpdata.Cells(r, c)
            i = i + 1
        End If
        Next c
    Next r
End Sub
 
 
 
#3
28.02.2024 21:39:27
Немного допиленная версия редизайнера (игнорирует пустые, запрашивает кол-во столбцов слева + уровней (строк) в шапке, работает с выделенным диапазоном, а также на новом листе добавляет заголовки):
Код
Sub Redesigner()

    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual

    Dim inpdata As Range, realdata As Range, ns As Worksheet
    Dim i&, j&, K&, c&, R&
    Dim hc As Variant, hr As Variant
    Dim out(), dataArr, hcArr, hrArr
    Dim i1 As Long, i2 As Long
    
    Set inpdata = Selection
    
    'оставляемые строки сверху
    hr = InputBox("Сколько строк с подписями сверху (равносильно - сколько уровней в шапке над значениями)?")
    
    If hr = Cancel Then GoTo e_end
    If Not (IsNumeric(hr)) Then
        y = MsgBox("Введенное значение не является числом")
        GoTo e_end
    End If

    'оставляемые столбцы слева
    hc = InputBox("Сколько столбцов с подписями слева?")
    
    If hc = Cancel Then GoTo e_end
    If Not (IsNumeric(hc)) Then
        y = MsgBox("Введенное значение не является числом")
        GoTo e_end
    End If

    'проверка по совпадениям с изначальным диапазоном
    If inpdata.Rows.Count <= hr Or inpdata.Columns.Count <= hc Then
        y = MsgBox("Одно из введенных значений превышает границы изначального диапазона")
        GoTo e_end
    End If
    
    'преобразование данных
    Set realdata = inpdata.Offset(hr, hc).Resize(inpdata.Rows.Count - hr, inpdata.Columns.Count - hc)
    dataArr = realdata.value
    If hr Then hrArr = inpdata.Offset(0, hc).Resize(hr, inpdata.Columns.Count - hc).value
    If hc Then hcArr = inpdata.Offset(hr, 0).Resize(inpdata.Rows.Count - hr, hc).value
    
    ReDim out(1 To Application.CountA(realdata), 1 To hr + hc + 1)
    Set ns = Worksheets.Add
    
    For i = 1 To UBound(dataArr, 1)
        For j = 1 To UBound(dataArr, 2)
            If Not IsEmpty(dataArr(i, j)) Then
                K = K + 1
                For c = 1 To hc: out(K, c) = hcArr(i, c): Next c
                For R = 1 To hr: out(K, c + R - 1) = hrArr(R, j): Next R
                out(K, c + R - 1) = dataArr(i, j)
            End If
    Next j, i
    
    'добавлениеданных на новый лист
    'ns.Cells(2, 1).Resize(UBound(out, 1), UBound(out, 2)) = out
    ns.Cells(hr + 1, 1).Resize(UBound(out, 1), UBound(out, 2)) = out
    
    'Заголовки слева
    For i1 = 1 To hr
        For i2 = 1 To hc
            ns.Cells(i1, i2) = inpdata(i1, i2)
        Next i2
    Next i1
    
    'Заголовки преобразованных столбцов
    If hr = 1 Then ns.Cells(hr, hc + 1) = "Столбцы"
    If hr > 1 Then
        For i1 = 1 To hr
            ns.Cells(hr, hc + i1) = "Столбцы_" & CStr(i1)
        Next i1
    End If

    'Заголовки значений
    ns.Cells(hr, CInt(hc) + CInt(hr) + 1) = "Значения"
    
    'Выделение заголовков
    ns.Cells(1, 1).Resize(hr, CInt(hc) + CInt(hr) + 1).Font.Bold = True
    ns.Cells(1, 1).Resize(hr, CInt(hc) + CInt(hr) + 1).Interior.Color = RGB(217, 217, 217)

e_end:

    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic

End Sub
 
 
 
#4
29.02.2024 17:46:47
Евгений Смирнов, - Макрос работает. Огромная благодарность!


aka_kd, Вам так-же огромная благодарность, но макрос на файле примере работает, а в рабочей среде - выдаёт ошибку, скрины привёл ниже:  
Изменено: Liameerf - 29.02.2024 17:47:46
 
 
 
#5
01.03.2024 22:04:57
Цитата
написал:
выдаёт ошибку, скрины привёл ниже
Хм, могу лишь предположить, что следует данную строку поправить так:
Код
ns.Cells(CInt(hr) + 1, 1).Resize(UBound(out(), 1), UBound(out(), 2)) = out()
Также высока вероятность, что в рабочей среде имя Out уже используется. Попробуйте в данной процедуре (Sub Redesigner) везде Out заменить на что-либо другое.
 
 
 
Страницы: 1
Наверх