vba 如何找到最小值，选择相应的值，将值复制并粘贴到新工作表
声明：本页面是StackOverFlow热门问题的中英对照翻译，遵循CC BY-SA 4.0协议，如果您需要使用它，必须同样遵循CC BY-SA许可，注明原文地址和作者信息，同时你必须将它归于原作者（不是我）：StackOverFlow
原文地址: http://stackoverflow.com/questions/5302397/
Warning: these are provided under cc-by-sa 4.0 license. You are free to use/share it, But you must attribute it to the original authors (not me):
StackOverFlow
How to find minimum, select the corresponding values, copy and paste the values to a new sheet
提问by Josh
Following is my problem description
以下是我的问题描述
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
First row has the headings. Column A has the serial number of the table. Columns B, C, and D are values coming out from some calculations. I want to write a VBA code such that the code finds the minimum value in the Column D, selects all the corresponding values of the row, copies and pastes just the values in a sheet named NewSheet.
第一行有标题。A 列包含表的序列号。B、C 和 D 列是一些计算得出的值。我想编写一个 VBA 代码，以便代码找到 D 列中的最小值，选择该行的所有相应值，仅复制并粘贴名为 NewSheet 的工作表中的值。
For the given case above, the VBA code should identify that the Cell D4 has the minimum value, it should select the corresponding values in row 4 (from cells B4, C4 and D4), copy these selected values and paste the values in the cells P2,Q2 and R2 of 'NewSheet'.
对于上面给定的情况，VBA 代码应该识别单元格 D4 具有最小值，它应该选择第 4 行中的相应值（从单元格 B4、C4 和 D4），复制这些选定的值并将值粘贴到单元格中'NewSheet' 的 P2、Q2 和 R2。
Since I am just a beginner, it will be highly appreciated if the responder can provide some comments that will help me to understand the code.
由于我只是一个初学者，如果响应者可以提供一些有助于我理解代码的评论，将不胜感激。
回答by Jean-Fran?ois Corbett
This will do the trick.
这将解决问题。
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
回答by strcompnice
Does this work?
这行得通吗？
This macro can be improved by writing a function that returns a column in a specified worksheet based on the column header. Then you would not have to hardcode the column numbers 4 and 16.
这个宏可以通过编写一个函数来改进，该函数根据列标题返回指定工作表中的列。那么您就不必对列号 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)
