L oop все значения в столбце A, чтобы найти все совпадения в столбце B

Question

Мой код находит все внутренние соединения во внешней книге, находит все скрытые листы.

Благодаря этим значениям я хотел бы добиться удаления всех скрытых листов, которые не являются источниками для любого другого листа в книге .

Я знаю, что это должно быть сделано с вложенным l oop, но у меня проблемы с его созданием.

1

For Each c In wbmacro.Sheets("Link Sheet").Range("D2:D10")
    For Each rc In wbmacro.Sheets("Link Sheet").Range("C2:C10")
        If c.Value <> rc.Value Then
            wbtarget.Sheets(c).Delete
        End If
    Next
Next

Я проверил все три ответа, при запуске кода ничего не происходит.

Полный код для проверки:

Sub a()

Dim xSheet As Worksheet
Dim xRg As Range
Dim xCell As Range
Dim xCount As Long
Dim xLinkArr() As String
Dim wbmacro As Workbook
Dim wbtarget As Workbook
Dim strfile As String
Dim strpath As String
Dim filename As String
Dim hsheet As String

Set wbmacro = ActiveWorkbook
filename = Application.GetOpenFilename(FileFilter:="Excel Files,*.xlsx")

Set wbtarget = Workbooks.Open(filename, UpdateLinks:=0)
        
On Error Resume Next

For Each xSheet In wbtarget.Sheets
    
    Set xRg = xSheet.UsedRange.SpecialCells(xlCellTypeFormulas)
    If xRg Is Nothing Then GoTo LblNext
    For Each xCell In xRg
        If InStr(1, xCell.Formula, "!") > 0 Then
            xCount = xCount + 1
            ReDim Preserve xLinkArr(1 To 2, 1 To xCount)
            xLinkArr(1, xCount) = xCell.Address(, , , True)
            xLinkArr(2, xCount) = "'" & xCell.Formula
       End If
    Next

LblNext:
Next

If xCount > 0 Then
    wbmacro.Activate
    wbmacro.Sheets("Link Sheet").Activate
    Range("A1").Resize(, 3).Value = Array("Location", "Reference", "Reference Sheet Name")
    Range("A2").Resize(UBound(xLinkArr, 2), UBound(xLinkArr, 1)).Value = Application.Transpose(xLinkArr)
    Columns("A:D").AutoFit
Else
    MsgBox "No links were found within the active workbook.", vbInformation
End If

x = 2
For Each ws In wbtarget.Worksheets
    If ws.Visible = xlSheetHidden Then
        wbmacro.Sheets("Link Sheet").Cells(x, 4) = ws.Name
        x = x + 1
    End If
Next ws

wbmacro.Activate
Columns("A:C").Select
ActiveSheet.Range("$A$1:$B$758").RemoveDuplicates Columns:=1, Header:=xlNo

Dim rc As Range
For Each c In wbmacro.Sheets("Link Sheet").Range("D2:D10").Cells
    ' The default behaviour is to delete the sheet
    bDeleteSheet = True
    For Each rc In wbmacro.Sheets("Link Sheet").Range("C2:C10").Cells
        If c.Value = rc.Value Then
            ' If you find the sheet name then it is used
            ' Do NOT delete it
            bDeleteSheet = False
            Exit For
        End If
    Next
    If bDeleteSheet Then wbtarget.Sheets(c).Delete
Next

End Sub

Answer 1

Попробуйте что-то вроде этого

Dim bDeleteSheet As Boolean

For Each c In wbmacro.Sheets("Link Sheet").Range("D2:D10").Cells
    ' The default behaviour is to delete the sheet
    bDeleteSheet = True
    For Each rc In wbmacro.Sheets("Link Sheet").Range("C2:C10").Cells
        If c.Value = rc.Value Then
            ' If you find the sheet name then it is used
            ' Do NOT delete it
            bDeleteSheet = False
            Exit For
        End If
    Next
    If bDeleteSheet Then wbtarget.Sheets(c).Delete
Next

Изменить: я добавил .Cells в две строки: По моему опыту, пропуск этого вызывал у меня некоторые проблемы в прошлом.

У меня также есть упомянуть, что это далеко не самый эффективный или динамичный код c, но он следует вашему logi c и является хорошей отправной точкой.

На самом деле в таком небольшом коде, любая оптимизация мало повлияет на время выполнения кода. Однако по мере того, как ваш код растет и / или у вас l oop через большее количество ячеек, есть способы оптимизировать ваш код.

• Чтобы сделать ваш код более эффективным, общее практическое правило состоит в том, чтобы свести к минимуму любое взаимодействие с приложением Excel и добиться того, чтобы вы гуглили такие темы, как «как читать мой диапазон в памяти в vba»

• Чтобы сделать ваш код более динамичным c google такие темы, как «как более динамично ссылаться на диапазоны в excel vba». В качестве примера, вместо жесткого кодирования номера строки 10 в вашем диапазоне, вы можете решить это следующим образом:

Dim lLastRow as Long
lLastRow = wbmacro.Sheets("Link Sheet").Range("C" & Columns.Count).End(xlUp).Row

Это то же самое, что и полностью до последней ячейки в столбце C и нажав Ctrl + Up, вы перейдете к последней использованной ячейке в этих столбцах, а затем прочитаете номер строки.

Теперь вы можете ссылаться на диапазон следующим образом:

wbmacro.Sheets("Link Sheet").Range("C2:C" & lLastRow)

Обратите внимание, что (из изображения выше) lLastRow теперь имеет значение 3, что означает, что ваш код не будет oop 7 раз без надобности.

Answer 2

l oop один раз и используйте Application.Match(), чтобы узнать, существует ли он:

For Each c In wbmacro.Sheets("Link Sheet").Range("D2:D10")
    If IsError(Application.Match(c,wbmacro.Sheets("Link Sheet").Range("C2:C10"),0)) and Len(c) > 0 then
        wbtarget.Sheets(c).Delete
    End If
Next

Answer 3

Думаю, что сейчас работает отлично. Я перепутал ваши коды:

Sub b()
Dim c As Range
Dim filename As String
Dim lLastRow1 As Long
Dim lLastRow2 As Long

Set wbmacro = ActiveWorkbook
filename = Application.GetOpenFilename(FileFilter:="Excel Files,*.xlsx")
Set wbtarget = Workbooks.Open(filename, UpdateLinks:=0)
lLastRow1 = wbmacro.Sheets("Link Sheet").Range("C" & Columns.Count).End(xlUp).row
lLastRow2 = wbmacro.Sheets("Link Sheet").Range("D" & Columns.Count).End(xlUp).row
Dim Ref As Range
wbmacro.Activate

For Each Ref In wbmacro.Sheets("Link Sheet").Range("D2:D" & lLastRow2).Cells

With Application
    On Error Resume Next
    Err.Clear
    result = .WorksheetFunction.Match(Ref.Value, Range("C2:C" & lLastRow1), 0)
    If Err.Number > 0 Then
        .DisplayAlerts = False
       MsgBox "Deleting: " & Ref.Value, vbOKOnly, _
              "Delete: Confirmation"
        wbtarget.Sheets(Ref.Value).Delete
        .DisplayAlerts = True
    End If
    
 End With

  Next Ref


 End Sub

Answer 4

Скотт и Двирони опередили меня, но я попал туда, пока они публиковали, вот код, который я придумал:

Sub Test()

Dim Ref As Range
  
For Each Ref In Range("HiddenSheets").Cells
 
   With Application
        On Error Resume Next
        Err.Clear
        Result = .WorksheetFunction.Match(Ref.Value, Range("References"), 0)
        If Err.Number > 0 Then
            .DisplayAlerts = False
           MsgBox "Deleting: " & Ref.Value, vbOKOnly, _
                  "Delete: Confirmation"
           ' wbtarget.Sheets(Ref.Value).Delete
            .DisplayAlerts = True
        End If
        
   End With
   
Next Ref

End Sub 'Test

Примечание: я установил две именованные ссылки Dynami c, поэтому он не Не имеет значения, сколько элементов находится в столбце C: имя «Ссылки» или столбец D: имя «HiddenSheets». Я также закомментировал оператор Delete и использовал окно сообщения, чтобы проверить, что происходит. Обратите внимание на использование DisplayAlerts, чтобы не появлялись диалоговые окна удаления, по которым можно было бы щелкнуть. Вам также нужно будет снова добавить в свои полностью квалифицированные ссылки для книг, из которых нужно удалить листы.

HTH