Страницы: 1
RSS
Почему при копировании берутся и скрытые ячейки?
 
Здравствуйте!

Попытался доработать чей-то макрос и сделать так, чтобы он копировал только видимые ячейки в другой выбираемый видимый диапазон, но почему-то не получается.
Вот код макроса:
Код
Sub PasteToVisible()
    Dim copyrng As Range, pasterng As Range
    Dim cell As Range, i As Long, newrng As Range
  
   'запрашиваем у пользователя по очереди диапазоны копирования и вставки
    Set copyrng = Application.InputBox("Диапазон копирования", "Запрос", Type:=8)
    Set pasterng = Application.InputBox("Диапазон вставки", "Запрос", Type:=8)
    
    'проверяем, чтобы они были одинакового размера
    If pasterng.SpecialCells(xlCellTypeVisible).Cells.Count <> copyrng.SpecialCells(xlCellTypeVisible).Cells.Count Then
        MsgBox "Диапазоны копирования и вставки разного размера!", vbCritical
        Exit Sub
    End If
  
    i = 1
    For Each cell In pasterng
        If cell.EntireRow.Hidden = False Then
            cell.value = copyrng.SpecialCells(xlCellTypeVisible).Cells(i).value
            i = i + 1
        End If
    Next cell
End Sub

Почему-то конструкция copyrng.SpecialCells(xlCellTypeVisible).Cells(i).value залезает в скрытые ячейки.
Как это можно исправить?
Изменено: borro - 29.03.2019 11:55:39
желаю всем счастья
 
Цитата
borro написал:
... SpecialCells(xlCellTypeVisible) ... залезает в скрытые ячейки. Как это можно исправить?
Надо вам использовать "Areas".

Или может хватит только так ?
Код
Sub PasteToVisible_1()
    Dim copyrng As Range, pasterng As Range
    
    Set copyrng = Application.InputBox("Kopirovaniye", "Zapros", Type:=8)
    Set pasterng = Application.InputBox("Vyberite tol'ko odnu yacheyku", "Zapros", Type:=8)
    
    copyrng.SpecialCells(xlCellTypeVisible).Copy Destination:=pasterng.Cells(1)
    Application.CutCopyMode = False
End Sub
 
Цитата
ocet p написал:
Надо вам использовать "Areas".
Спасибо. Это где их надо использовать?
Ваш макрос не подошел
Изменено: borro - 28.03.2019 17:53:47
желаю всем счастья
 
Попробовал и так:
Код
Sub PasteToVisible()
    Dim copyrng As Range, pasterng As Range
    Dim cell As Range, i As Long, newrng As Range, s As String
    
      
   'запрашиваем у пользователя по очереди диапазоны копирования и вставки
    Set copyrng = Application.InputBox("Диапазон копирования", "Запрос", Type:=8)
    Set pasterng = Application.InputBox("Диапазон вставки", "Запрос", Type:=8)
  
    'проверяем, чтобы они были одинакового размера
    If pasterng.SpecialCells(xlCellTypeVisible).Cells.Count <> copyrng.SpecialCells(xlCellTypeVisible).Cells.Count Then
        MsgBox "Диапазоны копирования и вставки разного размера!", vbCritical
        Exit Sub
    End If
     
    i = 0
    For Each cell In copyrng
        If i = 0 Then
            If cell.EntireRow.Hidden = False Then
                Set newrng = cell
                i = i + 1
            End If
        Else
            If cell.EntireRow.Hidden = False Then
                Set newrng = Union(newrng, cell)
            End If
        End If
    Next
    
    i = 1
    For Each cell In pasterng
        If cell.EntireRow.Hidden = False Then
            cell.Value = newrng.Cells(i).Value
            i = i + 1
        End If
    Next cell
End Sub

тоже не сработало. Попробую через адреса ячеек
желаю всем счастья
 
После ввода диапазонов
Код
copyrng.SpecialCells(xlCellTypeVisible).Copy pasterng.Cells(1, 1)
 
Kuzmich, так
Код
Sub PasteToVisible_1()
    Dim copyrng As Range, pasterng As Range
     
    Set copyrng = Application.InputBox("Kopirovaniye", "Zapros", Type:=8)
    Set pasterng = Application.InputBox("Vyberite tol'ko odnu yacheyku", "Zapros", Type:=8)
     
    copyrng.SpecialCells(xlCellTypeVisible).Copy pasterng.Cells(1, 1)
    Application.CutCopyMode = False
End Sub
?
Если да, то не сработало
желаю всем счастья
 
С адресом ячеек тоже не вышло:
Код
Sub PasteToVisible()
    Dim copyrng As Range, pasterng As Range
    Dim cell As Range, i As Long, newrng As Range, s As String
    s = ""
      
   'запрашиваем у пользователя по очереди диапазоны копирования и вставки
    Set copyrng = Application.InputBox("Диапазон копирования", "Запрос", Type:=8)
    Set pasterng = Application.InputBox("Диапазон вставки", "Запрос", Type:=8)
  
    'проверяем, чтобы они были одинакового размера
    If pasterng.SpecialCells(xlCellTypeVisible).Cells.Count <> copyrng.SpecialCells(xlCellTypeVisible).Cells.Count Then
        MsgBox "Диапазоны копирования и вставки разного размера!", vbCritical
        Exit Sub
    End If
     
    i = 0
    For Each cell In copyrng
        If cell.EntireRow.Hidden = False Then
            If i = 0 Then
                s = cell.Address
            Else
                s = s & ", " & cell.Address
            End If
            i = i + 1
        End If
    Next
    
    i = 1
    For Each cell In pasterng
        If cell.EntireRow.Hidden = False Then
            cell.Value = Range(s).Cells(i).Value
            i = i + 1
        End If
    Next cell
End Sub

Почему-то конструкция Range(s).Cells(i).Value берет ячейки даже из скрытого диапазона, хотя адреса зашитые в s только из тех, что относятся к видимым ячейкам
желаю всем счастья
 
Цитата
Если да, то не сработало
А что именно не сработало?
 
Цитата
Kuzmich написал:
А что именно не сработало?
Если воспользоваться вышеприведенным макросом с вашей конструкцией, то копируемые диапазон в части его видимых ячеек вставляется в место подстановки(диапазон вставки) подряд, включая срытые ячейки. А надо только в видимые
Изменено: borro - 28.03.2019 19:47:37
желаю всем счастья
 
Цитата
Если воспользоваться вышеприведенным макросом с вашей конструкцией
Выбрал первый диапазон A2:D4
второй диапазон A20
получил две строки

A    B   C  D
1              1
1              3
Изменено: Kuzmich - 28.03.2019 20:10:11
 
Цитата
borro написал:
... где их надо использовать?

Пожалуйста, попробуйте этот способ:
Код
Option Explicit

Sub PasteToVisible_2()
    Dim i As Long, j As Long
    Dim crng As Range, prng As Range, sngarr As Range, rrow As Range
    
    Set crng = Application.InputBox("Diapazon kopirowaniya", "Zapros", "List1!$A$1:$D$4", Type:=8).SpecialCells(xlCellTypeVisible)
    Set prng = Application.InputBox("Diapazon vstavki", "Zapros", "List2!$A$1:$D$4", Type:=8).SpecialCells(xlCellTypeVisible)
    
    i = crng.Columns.Count
    j = prng.Columns.Count
    
    If i <> j Then MsgBox "Raznyy razmer diapazonov: 'Stolbtse' - Konets", vbCritical: Exit Sub
    
    i = 0
    j = 0
    
    For Each sngarr In crng.Areas
        i = i + sngarr.Rows.Count
    Next
    For Each sngarr In prng.Areas
        j = j + sngarr.Rows.Count
    Next
    
    If i <> j Then MsgBox "Raznyy razmer diapazonov: 'Stroki' - Konets", vbCritical: Exit Sub
    
    i = 0
    j = 0
    
    Sheets(prng.Parent.Name).Select
    
    For Each sngarr In crng.Areas
        i = i + 1
        For Each rrow In sngarr.Rows
            j = j + 1
            rrow.Copy prng.Areas(i).Rows(j).Cells(1)
            Application.CutCopyMode = False
        Next
        j = 0
    Next
End Sub
 
Давно уже накидал подобный код. Изучайте: Как вставить скопированные ячейки только в видимые/отфильтрованные ячейки
Даже самый простой вопрос можно превратить в огромную проблему. Достаточно не уметь формулировать вопросы...
 
Всем спасибо!

Рабочий вариант получился такой:
Код
Sub PasteToVisible_2()
    Dim i As Long, j As Long, ii As Long, jj As Long, cnt As Long
    Dim crng As Range, prng As Range, sngarr As Range, rrow As Range, row As Range, arr As Range
     
    Set crng = Application.InputBox("Diapazon kopirowaniya", "Zapros", Type:=8).SpecialCells(xlCellTypeVisible)
    Set prng = Application.InputBox("Diapazon vstavki", "Zapros", Type:=8).SpecialCells(xlCellTypeVisible)
     
    i = crng.Columns.Count
    j = prng.Columns.Count
     
    If i <> j Then MsgBox "Raznyy razmer diapazonov: 'Stolbtse' - Konets", vbCritical: Exit Sub
     
    i = 0
    j = 0
     
    For Each sngarr In crng.Areas
        i = i + sngarr.Rows.Count
    Next
    For Each sngarr In prng.Areas
        j = j + sngarr.Rows.Count
    Next
     
    If i <> j Then MsgBox "Raznyy razmer diapazonov: 'Stroki' - Konets", vbCritical: Exit Sub
     
    j = 0
    ii = 0
    jj = 0
    cnt = 0
    Sheets(prng.Parent.Name).Select
     
    For Each sngarr In crng.Areas
        For Each rrow In sngarr.Rows
            j = j + 1
                For Each arr In prng.Areas
                    ii = ii + 1
                    For Each row In arr.Rows
                        jj = jj + 1
                        cnt = cnt + 1
                        If j = cnt Then
                            rrow.Copy prng.Areas(ii).Rows(jj).Cells(1)
                            Application.CutCopyMode = False
                            GoTo out
                        End If
                    Next row
                    jj = 0
                Next
out:
                ii = 0: jj = 0: cnt = 0
        Next
    Next
End Sub
желаю всем счастья
Страницы: 1
Наверх