vba 代码在 f8 中运行但在 f5 中不运行

Question

所以我查看了相同的问题和答案，但这对我的问题没有帮助。

这是代码

    Private Sub Update_To_Search_Click()
 Dim itmx As ListItem
 Set itmx = ListView1.FindItem(Number_Selected.Text, lvwText) ', , lvwPartial)
 If itmx Is Nothing Then
 MsgBox "No Record", vbCritical
 Else
 ListView1.ListItems(itmx.Index).Selected = True
 ListView1.SetFocus
 End If


Dim myindex As Integer
 Number_Selected.Text = Me.ListView1.SelectedItem
 myindex = Me.ListView1.SelectedItem.Index
 TextBox2.Text = Me.ListView1.ListItems.Item(myindex).SubItems(1)
 TextBox3.Text = Me.ListView1.ListItems.Item(myindex).SubItems(2)
 TextBox4.Text = Me.ListView1.ListItems.Item(myindex).SubItems(3)
 TextBox5.Text = Me.ListView1.ListItems.Item(myindex).SubItems(4)
 TextBox6.Text = Me.ListView1.ListItems.Item(myindex).SubItems(5)
 TextBox7.Text = Me.ListView1.ListItems.Item(myindex).SubItems(6)
 TextBox8.Text = Me.ListView1.ListItems.Item(myindex).SubItems(7)
 TextBox9.Text = Me.ListView1.ListItems.Item(myindex).SubItems(8)
 TextBox10.Text = Me.ListView1.ListItems.Item(myindex).SubItems(9)


'Go get the selected line


Dim Base As Worksheet, GoodData As Worksheet
Dim Rng As Range

Set GoodData = Sheets("GoodDBData")
Set Base = Sheets("Data")
Set wb = Workbooks("Staffing LogV1.7.xlsm")
Set listview = wb.Sheets("ListView")
Set fromsearch = wb.Sheets("FromDB")
Set Rng = Base.Range("A20:A28")

    FilePath = CStr(wb.Sheets("Data").Cells(2, "A"))
    filename = "DB.xlsx"
    Application.ScreenUpdating = False
  Set DB = Workbooks.Open(FilePath & "\" & filename)
   Application.ScreenUpdating = True


Rng.Copy
DB.Sheets("Search Criteria").Range("A2").PasteSpecial _
Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True

With DB.Sheets("DB")
    With .Rows(1)
    Selection.AutoFilter
    Selection.AutoFilter
    End With
End With


Dim rCrit1 As Range, rCrit2 As Range, rCrit3 As Range, rCrit4 As Range, rCrit5 As Range, rCrit6 As Range, rCrit7 As Range, rCrit8 As Range
Dim rRng1 As Range

With Application
    .EnableEvents = False
    .ScreenUpdating = False
End With

Set rCrit1 = Sheets("Search Criteria").Range("A2")
Set rCrit2 = Sheets("Search Criteria").Range("B2")
Set rCrit3 = Sheets("Search Criteria").Range("C2")
Set rCrit4 = Sheets("Search Criteria").Range("D2")
Set rCrit5 = Sheets("Search Criteria").Range("E2")
Set rCrit6 = Sheets("Search Criteria").Range("F2")
Set rCrit7 = Sheets("Search Criteria").Range("G2")
Set rCrit8 = Sheets("Search Criteria").Range("H2")

Set rRng1 = Sheets("DB").Range("A1").CurrentRegion

With rRng1
If rCrit1.Value <> "" Then
    .AutoFilter field:=11, Criteria1:=rCrit1.Value, Operator:=xlOr
End If

If rCrit2.Value <> "" Then
.AutoFilter field:=7, Criteria1:=rCrit2.Value, Operator:=xlOr
End If

If rCrit3.Value <> "" Then
    .AutoFilter field:=13, Criteria1:=rCrit3.Value, Operator:=xlOr
End If

If rCrit4.Value <> "" Then
    .AutoFilter field:=14, Criteria1:=rCrit4.Value, Operator:=xlOr
End If

If rCrit5.Value <> "" Then
    .AutoFilter field:=16, Criteria1:=rCrit5.Value, Operator:=xlOr
End If

If rCrit6.Value <> "" Then
    .AutoFilter field:=30, Criteria1:=rCrit6.Value, Operator:=xlOr
End If

If rCrit7.Value <> "" Then
    .AutoFilter field:=32, Criteria1:=rCrit7.Value, Operator:=xlOr
End If

If rCrit8.Value <> "" Then
    .AutoFilter field:=37, Criteria1:=rCrit8.Value, Operator:=xlOr
End If

End With


Application.EnableEvents = True
Application.ScreenUpdating = True


End sub

下面还是不复制粘贴条件找。由于某种原因，它只复制空白，没有在 Searcriteria 中输入数据。范围A2.

Rng.Copy
DB.Sheets("Search Criteria").Range("A2").PasteSpecial _
Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True

我迷路了，我正在寻找任何我能得到的帮助。非常感谢

Answer 1

帮我检查一下。

替换您的代码

    Base.Select
    Base.Range("A7:A15").Select
    Selection.Copy

    FilePath = CStr(wb.Sheets("Data").Cells(2, "A"))
    FileName = "DB.xlsx"
    Application.ScreenUpdating = False
    Set Db = Workbooks.Open(FilePath & "\" & FileName)
    Application.ScreenUpdating = True

    Sheets("Search Criteria").Select
    Range("A2").Select
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=True
    Sheets("DB").Select
    Rows("1:1").Select
    Selection.AutoFilter
    Selection.AutoFilter

有

Dim Rng As Range

Set Rng = Base.Range("A7:A15")

FilePath = CStr(wb.Sheets("Data").Cells(2, "A"))
FileName = "DB.xlsx"

Application.ScreenUpdating = False
Set Db = Workbooks.Open(FilePath & "\" & FileName)
Application.ScreenUpdating = True

Rng.Copy
Db.Sheets("Search Criteria").Range("A2").PasteSpecial _
Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True

With Db.Sheets("Search Criteria")
    With .Rows(1)
        '~~> REST OF THE CODE
    End With
End With

现在试试看？

vba 代码在 f8 中运行但在 f5 中不运行

vba code runs in f8 but not in f5

excel

vba

cumulative-sum