Как сделать исключения в копии строки

Question

Я новичок в макросах. Мне нужно сделать копию строк, но я должен исключить некоторые столбцы. WholeRow работает, но мне нужно исключить столбцы I, G, H

Sub Macro1()
    Dim RngToChk as Range, RngToPaste as Range
    Set RngToCheck=Application.InputBox(Prompt:="enter range", Type:=8)
    Dim strtofind as String
    Inttofind=InputBox("Give your Indicator")
    Dim i as long
    For i = RngToChk.Rows.Count To 1 Step -1
        If RngToChk(i).value=strtofind Then
            RngToCheck(i).Offset(1).EntireRow.Insert
            Set RngToPaste=RngToChk(i).Offset(1)
            RngToPaste.EntireRow.Value=RngToChk(i).EntireRow.Value
            RngToPaste.EntireRow.Font.Color=RGB(255,0,0)
        End If
    Next i
End Sub

Answer 1

Добавьте эту функцию в ваш модуль:

Function AlmostEntireRow(StartingPoint As Range) As Range
    Dim Row As Long
    Dim TargetSheet As Worksheet
    Row = StartingPoint.Row
    Set TargetSheet = StartingPoint.Worksheet
    Set AlmostEntireRow = Union(TargetSheet.Range("A" & Row & ":F" & Row), TargetSheet.Range("J" & Row & ":GR" & Row))
End Function

Когда вы используете его, замените

RngToPaste.EntireRow.Font.Color=RGB(255,0,0)

на

AlmostEntireRow(RngToPaste).Font.Color = RGB(255, 0, 0)

и т. Д.

Функция строит диапазон из диапазона ввода, состоящий из столбцов от A до F и от J до GR. Отрегулируйте при необходимости.

Обновление
Предлагаемый метод не работает при копировании строк. Вот и метод копирования.

Sub CopyAlmostEntireRow(FromRow As Range, ToRow As Range)
    Dim FromRange As Range
    Dim ToRange As Range

    Set FromRange = FromRow.Worksheet.Range("A" & FromRow.Row & ":F" & FromRow.Row)
    Set ToRange = ToRow.Worksheet.Range("A" & ToRow.Row & ":F" & ToRow.Row)
    ToRange.Value = FromRange.Value

    Set FromRange = FromRow.Worksheet.Range("J" & FromRow.Row & ":GR" & FromRow.Row)
    Set ToRange = ToRow.Worksheet.Range("J" & ToRow.Row & ":GR" & ToRow.Row)
    ToRange.Value = FromRange.Value

End Sub

' Call with something like this:
CopyAlmostEntireRow RngToChk(i), RngToPaste