Question

我在excel中有一个问题的VBA代码。我要求用户给出一个数字（实际上是一周的数字）。该数据将设置为范围Q1。我已将日期（已经在表格中）转换为“K”列到周数，其公式为“Weeknum”。现在我想只保留那些rowwich与单元格“Q1”中显示的用户条目相等。

现在的结果是，工作表仅将weeknum显示为值而不是公式，但没有删除任何内容。

你能帮帮我吗？

提前致谢！

    range("K6").FormulaR1C1 = "=WEEKNUM(RC[-10])"
range("K6").Select
Selection.AutoFill Destination:=range("K6:K65536")

range("K6:K65536").Copy
range("K6:K65536").PasteSpecial xlPasteValues

Dim Valid3 As Boolean
Dim Data3 As String

While Valid3 = False
    het = InputBox("Kérlek, add meg melyik hétre szűrjek rá!", "További szűrés beállítása", "")
    If IsNumeric(het) Then
            Valid3 = True
            range("Q1").Value = het
        Else
            Valid3 = False
            MsgBox "HIBA! Valószínűleg rossz formátumban adtad meg a szűrendő hetet."
    End If
Wend

    Dim Rng3 As range
    Dim x3 As Long
    Set Rng3 = range("K6:K" & range("K65536").End(xlUp).Row)
    For x3 = Rng3.Rows.Count To 1 Step -1
        If InStr(1, Rng3.Cells(x3, 1).Value, range("Q1")) = 0 Then
            Rng3.Cells(x3, 1).EntireRow.Delete
        End If
    Next x3

Answer 1

列K只包含一个数字，即周数，因此您不需要像

那样复杂的任何内容

InStr（1，Rng3.Cells（x3,1）.Value，range（“Q1”））

我会这样做：

Set Rng3 = range("K6")
Do while not Rng3 = ""
  If Rng3.value = het then
    Set Rng3 = Rng3.Offset(1,0)
    Rng3.Offset(-1,0).EntireRow.Delete
  Else
    Set Rng3 = Rng3.Offset(1,0)
  End if
Loop

请注意，删除单个行的速度很慢，如果您有大量数据可能会变得非常缓慢。

有一种替代方法会更快：

过滤列K值不等于het
仅转到特殊的可见细胞
清除活跃细胞
删除过滤器

Answer 2

您可以尝试这样的事情......

Sub DeleteRows()
Dim i As Long, lr As Long, het As Long
Dim Valid3 As Boolean
Dim Rng As Range

Application.ScreenUpdating = False

lr = Cells(Rows.Count, "A").End(xlUp).Row
Range("K6:K" & lr).Formula = "=WEEKNUM(A6)"
Range("K6:K" & lr).Value = Range("K6:K" & lr).Value

While Valid3 = False
    het = InputBox("Kérlek, add meg melyik hétre szurjek rá!", "További szurés beállítása", "")
    If IsNumeric(het) Then
            Valid3 = True
            Range("Q1").Value = het
        Else
            Valid3 = False
            MsgBox "HIBA! Valószínuleg rossz formátumban adtad meg a szurendo hetet."
    End If
Wend

For i = lr To 6 Step -1
     If Cells(i, "K") <> het Then
        If Rng Is Nothing Then
            Set Rng = Cells(i, "K")
        Else
            Set Rng = Union(Rng, Cells(i, "K"))
        End If
     End If
Next i

If Not Rng Is Nothing Then Rng.EntireRow.Delete
Application.ScreenUpdating = True
End Sub

Answer 3

感谢你们两位的回答。不幸的是，这些解决方案仍未解决问题。现在我为你复制整个代码，希望你可能会看到我不能做到的。 :)现在我插入原始代码，不包含您的解决方案。

有趣的是，我要求用户提供3个数据。所有数据都以相同的方式询问，对于前两个运行，代码工作完美，但第三个。

    Sub SzponzorSzűrő()

Dim Valid As Boolean
Dim Data As String

While Valid = False
        csatorna = InputBox("Kérlek, add meg a szűrendő csatorna nevét!", "Szűrendő csatorna", "")
        If Not IsNumeric(csatorna) Then
                Valid = True
                range("Q1").Value = csatorna
        Else
                Valid = False
                MsgBox "HIBA! Valószínűleg rosszul adtad meg a szűrendő csatorna nevét."
    End If
Wend

    Dim rng As range
    Dim X As Long
    Set rng = range("D6:D" & range("D65536").End(xlUp).Row)
    For X = rng.Rows.Count To 1 Step -1
        If InStr(1, rng.Cells(X, 1).Value, range("Q1")) = 0 Then
                rng.Cells(X, 1).EntireRow.Delete
        End If
    Next X
range("Q1").Delete

valasztas = MsgBox("Szeretnéd, hogy tovább szűrjem a listát egy adott hétre?", vbYesNo + vbQuestion, "További szűrési lehetőségek")
If valasztas = vbYes Then

Dim Valid2 As Boolean
Dim Data2 As String

While Valid2 = False
        datum = InputBox("Kérlek, add meg hogy melyik évre szűrjek rá!", "További szűrés beállítása", "")
        If IsNumeric(datum) Then
            Valid2 = True
            range("Q1").Value = datum
            Else
            Valid2 = False
                MsgBox "HIBA! Valószínűleg rossz formátumban adtad meg a szűrendő évet."
        End If
    Wend

Dim Rng2 As range
    Dim x2 As Long
    Set Rng2 = range("A6:A" & range("A65536").End(xlUp).Row)
 For x2 = Rng2.Rows.Count To 1 Step -1
     If InStr(1, Rng2.Cells(x2, 1).Value, range("Q1")) = 0 Then
        Rng2.Cells(x2, 1).EntireRow.Delete
    End If
Next x2
range("Q1").Delete

range("K6").FormulaR1C1 = "=WEEKNUM(RC[-10])"
range("K6").Select
Selection.AutoFill Destination:=range("K6:K65536")

range("K6:K65536").Copy
range("K6:K65536").PasteSpecial xlPasteValues

Dim Valid3 As Boolean
Dim Data3 As String

While Valid3 = False
het = InputBox("Kérlek, add meg melyik hétre szűrjek rá!", "További szűrés beállítása", "")
If IsNumeric(het) Then
        Valid3 = True
        range("Q1").Value = het
    Else
        Valid3 = False
        MsgBox "HIBA! Valószínűleg rossz formátumban adtad meg a szűrendő hetet."
End If
Wend

Dim Rng3 As range
Dim x3 As Long
Set Rng3 = range("K6:K" & range("K65536").End(xlUp).Row)
For x3 = Rng3.Rows.Count To 1 Step -1
    If InStr(1, Rng3.Cells(x3, 1).Value, range("Q1")) = 0 Then
        Rng3.Cells(x3, 1).EntireRow.Delete
    End If
Next x3

MsgBox ("A szponzorok leszűrve egy adott csatornára és egy megadott hétre.")
Else
MsgBox ("A szponzorok leszűrve egy adott csatornára.")
End If

End Sub

如果单元格与单元格的值相等，则删除整行

3 个答案: