Excel макрос копирование не пустых ячеек

Доброго времени суток господа!

Помогите с макросом который будет копировать значения только заполненных ячеек ( то есть пустые ячейки он не трогает) из одного массива в другой, В примере указан массив копирования и массив вставки. И чтобы имеющиеся значения в массиве вставке не затрагивались. Спасибо

Так же указан желаемый результат.

Прикрепленные файлы

Впитываю знания, как борщ после тренировки ^^)

Помогите победить ошибку,excel не копирует разные фрагменты, что делать?

Sub Макрос1()
With Worksheets("Лист1")
    Sheets("Лист1").Select
    Range("B5:F32").Select
    Selection.SpecialCells(xlCellTypeConstants, 1).Select
    Selection.Copy
    Range("J9:N36").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
            Application.CutCopyMode = False
End With
End Sub

Впитываю знания, как борщ после тренировки ^^)

Быстрее молнии, быстрее ветра, быстрее калькулятора

Молодое_Поколение, Добрый день, еще вариант.

Option Base 1
Sub sss()
Dim arrin, arrout(1 To 27, 1 To 5)
arrin = Range("B6:F32")
For r = 1 To 27
    For c = 1 To 5
        If IsEmpty(arrin(r, c)) Then
            arrout(r, c) = "хххххххх"
        Else
            arrout(r, c) = arrin(r, c)
        End If
    Next c
Next r
Range("J6:N32") = arrout
End Sub

Не бойтесь совершенства. Вам его не достичь.

Borrusale, в рабочем варианте большая таблица тормозит сильно, есть способы быстрее сделать? прикрепил пример рабочей таблицы с вашим макросом
Файл весит 316кб — поместил в облако

https://cloud.mail.ru/public/3FFv/CJdPrWkHY

Mershik, ваш вариант неплохой, но он заменяет пробелы на «хххххх», а мне нужно чтобы он проблемы не трогал вообще, я сделал чтобы пробелы заменялись на «», так он все равно вставляет пробелы из первой таблицы во вторую.    по производительности ваш быстрее, привел файл с примером рабочим в предыдущем сообщении

Впитываю знания, как борщ после тренировки ^^)

Впитываю знания, как борщ после тренировки ^^)

какой именно? Этой?

Так в его коде на «хххххх» заменяются не пробелы, а пустые ячейки. Вам что нужно?

зы.
Вы ж сами показали, в «Как должно быть — «хххххх»

Изменено: Михаил Витальевич С. — 30.08.2020 18:05:56

Впитываю знания, как борщ после тренировки ^^)

Быстрее молнии, быстрее ветра, быстрее калькулятора

вот так будет чуть быстрее, но не очень:

Sub help()
'
    Set SourceRng = Range("A1:ai1000")
    Set ResultRng = Range("AK1:BS1000")
    Set InsertRng = Range("AK1:BS1000")
    Application.ScreenUpdating = False 'отключаем экран
    For i = 1 To SourceRng.Count
        If Len(SourceRng.Item(i).Value) = 0 Then
            ResultRng.Item(i).Value = InsertRng.Item(i).Value
        Else
            ResultRng.Item(i).Value = SourceRng.Item(i).Value
        End If
    
    Next
    Application.ScreenUpdating = True 'включаем экран
   
End Sub

######################################
PS.
А почему нельзя

Sub ttt()
    Range("A1").CurrentRegion.Copy Range("AK1")
End Sub

не понял

Изменено: Михаил Витальевич С. — 30.08.2020 18:33:19

Borrusale, ваш макрос работает так как я и хотех единственное, что нужно быстрее — массив состоит из 35 000 ячеек, да и к тому же некоторые строки имеют по 250 символов …. очень долго…

А пробел — первая таблица 37 строка

Впитываю знания, как борщ после тренировки ^^)

у Вас всего 27 строк. Адрес ячейки пожалуйста ? Например «B15» «D7»
Пробелы есть только в названиях таблиц (ctrl+F не находит на листе пробелы)

Быстрее молнии, быстрее ветра, быстрее калькулятора

Михаил Витальевич С.,

для чего это мне нужно?

каждый день обновляется база новые значения копируются в таблицу, бывает так что некоторые значения не прогружаются и на их месте пустая ячейка — мне нужно чтобы пустые ячейки НЕкопировались.. Тоесть чтобы в таблице всегда были последние обновленные значения.

Изменено: Молодое_Поколение — 30.08.2020 18:39:39

Впитываю знания, как борщ после тренировки ^^)

Borrusale, Borrusale,

файл с 35 000 ячейками весит больше 100кб — поэтому я поместил его в облако

https://cloud.mail.ru/public/3FFv/CJdPrWkHY

Впитываю знания, как борщ после тренировки ^^)

Может так подойдёт? )

Sub ttt()
Dim iRow As Long, LastRow As Long
    
    Application.ScreenUpdating = False
    LastRow = Cells(Rows.Count, "A").End(xlUp).Row
    Range("A1:AI" & LastRow).Copy Range("AK1")
    LastRow = Cells(Rows.Count, "AK").End(xlUp).Row
    For iRow = LastRow To 1 Step -1
        If Len(Cells(iRow, "AK")) = 0 Then Rows(iRow).EntireRow.Delete
    Next iRow
    Application.ScreenUpdating = True
End Sub

Молодое_Поколение,я не могу его открыть . Мое предположение что в пустых ячейках что то есть. Замените IsEmpty на len в коде  предложенном Mershik:

Option Base 1Sub sss()
Dim arrin, arrout(1 To 27, 1 To 5)
arrin = Range("B6:F32")
For r = 1 To 27
    For c = 1 To 5
        If len(arrin(r, c))=0 Then
            arrout(r, c) = "хххххххх"
        Else
            arrout(r, c) = arrin(r, c)
        End If
    Next c
Next r
Range("J6:N32") = arrout
End Sub

Быстрее молнии, быстрее ветра, быстрее калькулятора

Впитываю знания, как борщ после тренировки ^^)

Думаю технически быстрее будет сперва удалить эти немногие пустые строки в источнике (были тут супербыстрые коды, например от ZVI

https://www.planetaexcel.ru/forum/index.php?PAGE_NAME=message&FID=8&TID=24531&TITLE_SEO=24531&MID=335928#message335928

), а уже затем весь нормализованный диапазон и скопировать. Если ещё нужно.

пока что лучшее решение вот это

Sub help()
'
    Set SourceRng = Range("A1:ai1000")
    Set ResultRng = Range("AK1:BS1000")
    Set InsertRng = Range("AK1:BS1000")
    Application.ScreenUpdating = False 'отключаем экран
    For i = 1 To SourceRng.Count
        If Len(SourceRng.Item(i).Value) = 0 Then
            ResultRng.Item(i).Value = InsertRng.Item(i).Value
        Else
            ResultRng.Item(i).Value = SourceRng.Item(i).Value
        End If
     
    Next
    Application.ScreenUpdating = True 'включаем экран
    
End Su

Впитываю знания, как борщ после тренировки ^^)

Михаил Витальевич С., так точно!

Надо научиться у вас правильно объяснять

Впитываю знания, как борщ после тренировки ^^)

Не бойтесь совершенства. Вам его не достичь.

на основе макроса Mershik, из #5 и файла из первого сообщения:

Sub ttt()
    Dim arrin(), arrout(), R&, C&
    arrin = Range("B6").CurrentRegion.Value
    arrout = Range("J10").CurrentRegion.Value
    
    For R = 1 To UBound(arrin)
        For C = 1 To UBound(arrin, 2)
            If Len(arrin(R, C)) = 0 Or arrin(R, C) = " " Then
        '        ни чего не делаем
            Else
                arrout(R, C) = arrin(R, C)
            End If
        Next C
    Next R
    Range("J10").CurrentRegion.Value = arrout
End Sub

Прикрепленные файлы

Изменено: Михаил Витальевич С. — 30.08.2020 19:54:34

Впитываю знания, как борщ после тренировки ^^)

    Range("B6").CurrentRegion.Copy
    Range("J10").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=True

Я что-то упустил? на примере из облака 1.7 секунды

По вопросам из тем форума, личку не читаю.