Попытался доработать чей-то макрос и сделать так, чтобы он копировал только видимые ячейки в другой выбираемый видимый диапазон, но почему-то не получается. Вот код макроса:
Код
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 написал: ... 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
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
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 только из тех, что относятся к видимым ячейкам
Если воспользоваться вышеприведенным макросом с вашей конструкцией, то копируемые диапазон в части его видимых ячеек вставляется в место подстановки(диапазон вставки) подряд, включая срытые ячейки. А надо только в видимые
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