Question

我正在编写一个脚本，我希望在数据库中启用搜索，在不同的工作表（我将其命名为Results）中显示搜索查询的结果，以便用户无法访问整个数据库同时。

为了做到这一点，我想将“数据库”工作表中的值复制到“结果”工作表中。我已经成功地从“数据库”中选择了与任何特定搜索条件相关的正确数据。我用以下代码完成了这个：

With Sheets("Database")
   .Range(.Cells(i, 1), .Cells(i, 9)).Copy
End With

现在我想将结果粘贴到“结果”电子表格中，我已经写了以下内容：

Sheets("Results").Range("B600").End(xlUp).Offset(1, 0).PasteSpecial xlPasteFormulasAndNumberFormats

通过这样做，我不太明白：

如果我在第一个空行和B600之间严格定义了粘贴范围，或者
如果我只是定义粘贴范围的开头，并且在搜索结果超过第600行的情况下，它们仍然会粘贴在此行之后。

我问这个是因为随着数据库的增长，我当然需要保证粘贴范围大于B600。

我已经对它进行了研究，但似乎无法完全确定我所做的事情。我必须说我知道“结果”数据库中的第一个空行总是12个。在这种情况下，我知道我基本上想要粘贴第12行的搜索结果。也许有更简单的方法来做到这一点。

这是整个代码，供参考：

Private Sub SearchButton_Click()

'This is the search function

'1. declare variables
'2. clear old search results
'3. Find records that match criteria and paste them

Dim country As String
Dim Category As String
Dim Subcategory As String
Dim finalrow As Integer
Dim i As Integer 'row counter


'Erase any entries from the Results sheet
Sheets("Results").Range("B10:J200000").ClearContents

'Deformat any tables in the Results sheet
For Each tbl In Sheets("Results").ListObjects
    tbl.Clear

    Next

'Define the user-inputed variables
country = Sheets("Results").Range("D5").Value
Category = Sheets("Results").Range("D6").Value
Subcategory = Sheets("Results").Range("D7").Value
finalrow = Sheets("Database").Range("A" & Rows.Count).End(xlUp).Row

'If statement for search

'For every variable i, start comparing from row 2 until the final row
For i = 2 To finalrow

    'If the country field is left empty
    If country = "" Then
        Sheets("Results").Range("B10:J200000").Clear
        MsgBox "You must select a country in order to search the database. Please do so in the drop-down list provided."
        Sheets("Results").Range("D5").ClearContents
        Sheets("Results").Range("D6").ClearContents
        Sheets("Results").Range("D7").ClearContents
        Exit Sub

    'If the country field is filled in and there results from the search made
    ElseIf Sheets("Database").Cells(i, 1) = country And _
        (Sheets("Database").Cells(i, 3) = Category Or Category = "") And _
        (Sheets("Database").Cells(i, 4) = Subcategory Or Subcategory = "") Then

            'Copy the headers of the table
            With Sheets("Database")
            .Range("A1:I1").Copy
            End With
            Sheets("Results").Range("B10:J10").PasteSpecial

            'Copy the rows of the table that match the search query
            With Sheets("Database")
            .Range(.Cells(i, 1), .Cells(i, 9)).Copy
            End With
            Sheets("Results").Range("B600").End(xlUp).Offset(1, 0).PasteSpecial xlPasteFormulasAndNumberFormats

    'Hides search form
    Me.Hide

    End If

Next i

'Toggle Results sheet
Sheets("Results").Activate

'Format results as a table
Set rng = Range(Range("B10"), Range("B10").End(xlUp).SpecialCells(xlLastCell))
Set table = Sheets("Results").ListObjects.Add(xlSrcRange, rng, , xlYes)
table.TableStyle = "TableStyleMedium13"

Range("B11").Select

'Make Excel window visible
Application.Visible = True

End Sub

非常感谢你的帮助。

Answer 1

您可以从工作表底部到B列中最后使用的单元格进行计数，然后OFFSET进行1行计数。这可以防止您需要担心

a）要粘贴的范围从第12行开始（它们应包含值）和

b）您目前正在使用B600的硬编码“锚点”，随着数据的增长需要更新。

示例代码：

Dim ws As Worksheet
Dim rngColumnBUsed As Range
Dim lngFirstEmptyRow As Long

Set ws = ThisWorkbook.Sheets("Results")
Set rngColumnBUsed = ws.Range("B" & ws.Rows.Count).End(xlUp).Offset(1, 0)
lngFirstEmptyRow = rngColumnBUsed.Row

Answer 2

将搜索数据调暗为范围，输入用户为字符串

inputfromuser = inputbox（＆＃34;键入您要搜索的内容＆＃34;）

设置searchdata = sheets（＆＃34;数据库＆＃34;）。find（inputfromuser）.select

searchdata = activecell.value或activecell.offset（10,5）.value

片（＆＃34;结果＆＃34）。激活

表格（＆＃34;结果＆＃34;）

范围（＆＃34; A12＆＃34;，范围（＆＃34; A12＆＃34;。）端部（xldown））。偏移（1,0）。选择

searchdata.copy destination：= activecell

activecell.offset（1,0）。选择

以

结束

不确定，如果我理解你的核心配偶。

我没有表格或VBE编辑器。只是直接在网站上写这个。请根据您的需要进行修改。

Answer 3

两个ListObject tblDatabase和tblResults
tblResults数据已清除
过滤器应用于tblDatabase
如果结果少于588条，我们会将过滤后的记录从tblDatabase复制到tblResults
如果结果超过588，我们会调整过滤后的记录的大小。范围下至前588条记录，然后将其复制到tblResults
我们从不担心格式化，因为tblResults保留了原始格式。

Sub ListObjectDemo()
    Dim tblDatabase As ListObject, tblResults As ListObject

    Set tblDatabase = Worksheets("Database").ListObjects("tblDatabase")
    Set tblResults = Worksheets("Results").ListObjects("tblResults")
    If Not tblResults.DataBodyRange Is Nothing Then tblResults.DataBodyRange.ClearContents

    With tblDatabase.Range
        .AutoFilter Field:=2, Criteria1:="Test A"
        .AutoFilter Field:=3, Criteria1:="East"
        .AutoFilter Field:=4, Criteria1:="Algeria"
    End With

    With tblDatabase.DataBodyRange
        If .Rows.Count <= 588 Then
            .Copy tblResults.ListRows.Add.Range
        Else
            .Resize(588).Copy tblResults.ListRows.Add.Range
        End If
    End With

End Sub

在动态范围内粘贴值excel vba

3 个答案: