Question

以下是我的问题描述

      A    B    C    D     
   1  H1   H2   H3   H4   
   2  1    3    4    2      
   3  2    4    1    8     
   4  3    1    6    1       
   5  4    2    8    5

第一行有标题。列A具有表的序列号。列B，C和D是来自某些计算的值。我想编写一个VBA代码，以便代码在D列中找到最小值，选择行的所有相应值，只复制和粘贴名为NewSheet的工作表中的值。

对于上面给出的情况，VBA代码应该识别Cell D4具有最小值，它应该选择第4行中的相应值（来自单元格B4，C4和D4），复制这些选定的值并粘贴值在'NewSheet'的单元格P2，Q2和R2中。

由于我只是一名初学者，如果响应者可以提供一些有助于我理解代码的评论，我们将非常感激。

Answer 1

这样就可以了。

Option Explicit ' Forces you to declare variables. Helps prevent stupid mistakes.

Sub Rabbit()

' Declare variables. Can also spread this throughout your code...
Dim rngData As Range
Dim rngTarget As Range
Dim varData As Variant
Dim iCounter As Long
Dim iMinH4 As Long
Dim dblMinH4 As Double
Dim shtNew As Worksheet

' Where to get the data from (H1...H4 headers not included here)
Set rngData = Worksheets("Sheet1").Range("A2").Resize(4, 4)

' Get all data from sheet at once. Faster than interrogating sheet multiple times.
varData = rngData

' Get first entry. This is the minimum so far, by definition...
iMinH4 = 1
dblMinH4 = varData(1, 4)
' Go through all other entries to see which is minimum.
For iCounter = LBound(varData, 1) +1 To UBound(varData, 1) ' +1 since first entry already checked
    If varData(iCounter, 4) < dblMinH4 Then
        ' This is the minimum so far.
        dblMinH4 = varData(iCounter, 4)
        iMinH4 = iCounter
    Else
        ' This is not the minimum.
        ' Do nothing.
    End If
Next iCounter

' If creating new sheet is necessary, uncomment this:
'Set shtNew = ActiveWorkbook.Worksheets.Add
'shtNew.Name = "NewSheet"

' Where should the values go?
Set shtNew = ActiveWorkbook.Worksheets("NewSheet")
Set rngTarget = shtNew.Range("P2:R2")

' Copy the values over to NewSheet.
rngData.Cells(iMinH4, 1).Resize(1, 3).Copy rngTarget

End Sub

Answer 2

这有用吗？

可以通过编写一个函数来改进此宏，该函数根据列标题返回指定工作表中的列。然后，您不必对列号4和16进行硬编码。

Dim newSheet As Worksheet
Dim yourWorksheet As Worksheet
Dim searchArea As Range
Dim searchResult As Range
Dim yourWorkbook As String
Dim rowMinimum As Long
Dim minimumValue As Long
Dim columnSearch As Integer
Dim columnNew As Integer

columnSearch = 4
columnNew = 16

yourWorkbook = [workbook name]

Set yourWorksheet = Workbooks(yourWorkbook).Worksheets([worksheet name])
Set newSheet = Workbooks(yourWorkbook).Worksheets("NewSheet")

'Select all the cells in the column you want to search down to the first empty
'cell.
Set searchArea = yourWorksheet.Range(yourWorksheet.Cells(2, columnSearch), _
yourWorksheet.Cells(yourWorksheet.Cells(2, columnSearch).End(xlDown).Row, _
columnSearch))

'Determine the minimum value in the column.
minimumValue = Application.Min(searchArea)

'Find the row that contains the minimum value.
Set searchResult = yourWorksheet.Columns(columnSearch).Find(What:=minimumValue, _
After:=yourWorksheet.Cells(1, columnSearch), LookIn:=xlValues, LookAt:=xlWhole, _
SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, _
SearchFormat:=False)

'Store the row that contains the minimum value in a variable.
rowMinimum = searchResult.Cells.Row

'Copy the other cells in the row containing the minimum value to the new
'worksheet.
yourWorksheet.Range(yourWorksheet.Cells(rowMinimum, 1), _
yourWorksheet.Cells(rowMinimum, columnSearch - 1)).Copy _
Destination:=newSheet.Cells(2, columnNew)

如何查找最小值，选择相应的值，将值复制并粘贴到新工作表中

2 个答案: