如何在Excel VBA中将最高值和剩余值复制到不同的单元格

我想从主表中select前10个值，并粘贴在不同的范围（E3）和剩余的所有值和PASTE和SUM在另一个范围（I3）我使用下面的代码。 它正在为十大值，但剩下，当我在主表中添加一行，它不工作。 帮我。

Private Sub CommandButton1_Click() 'Calculation for Top 10 Countries Sheets("Sheet1").Range("C" & Rows.Count).End(xlUp).Offset(-9, -2).Resize(10, 3).Copy Sheets("Sheet1").Range("E3") 'Calculation for Remaining Countries Range("A3:C14").Copy Range("I3") Range("I15").Select ActiveCell.FormulaR1C1 = "Remaining" Range("J15").Select ActiveCell.FormulaR1C1 = "=SUM(R[-12]C:R[-1]C)" Range("K15").Select ActiveCell.FormulaR1C1 = "=SUM(R[-12]C:R[-1]C)" End Sub 

Answer 1

请试试这个代码。

 Option Explicit Private Sub CommandButton1_Click() Dim Rng As Range Dim R As Long, Rl As Long ' last row With Worksheets("Sheet1") Rl = .Cells(.Rows.Count, "A").End(xlUp).Row R = Application.Max(Rl - 9, 3) ' pick Top 10 Countries Set Rng = Range(.Cells(R, "A"), .Cells(Rl, "C")) Rng.Copy Destination:=.Cells(3, "E") ' pick remaining countries If R > 3 Then Set Rng = Range(.Cells(3, "A"), .Cells(R - 1, "C")) Rng.Copy Destination:=.Cells(3, "I") ' write totals Rl = .Cells(.Rows.Count, "I").End(xlUp).Row Set Rng = Range(.Cells(3, "J"), .Cells(Rl, "J")) Rl = Rl + 1 With .Cells(Rl, "I") .Value = "Remaining" .HorizontalAlignment = xlRight .Font.Bold = True End With With .Cells(Rl, "J") .Value = Application.Sum(Rng) .HorizontalAlignment = xlCenter .Font.Bold = True End With With .Cells(Rl, "K") .Value = Application.Sum(Rng.Offset(0, 1)) .HorizontalAlignment = xlCenter .Font.Bold = True End With End If End With End Sub 

Answer 2

 Private Sub CommandButton1_Click() Dim lr As Long Dim pr As Long With Sheets("Sheet1") lr = .Range("A" & Rows.Count).End(xlUp).Row 'Calculation for Top 10 Countries .Range("A" & (lr - 10) & ":C" & lr).Copy .Range("E3") 'Calculation for Remaining Countries .Range("A3:C" & (lr - 11)).Copy .Range("I3") pr = .Range("A3:C" & (lr - 11)).Rows.Count + 3 .Range("I" & pr).Value = "Remaining" .Range("J" & pr).FormulaR1C1 = "=SUM(R[-12]C:R[-1]C)" .Range("K" & pr).FormulaR1C1 = "=SUM(R[-12]C:R[-1]C)" End With End Sub 

Answer 3

下面的代码首先按照国家（硬编码选项）对主表进行sorting，然后在列E和列E中创build2个已sorting表的副本，并按照降序或升序sorting（硬编码选项），并删除每个部分，需要。 用户可以select要确定排名的年份，并且程序允许将更多的年份添加到主表并且在不改变代码的情况下处理。 您可能希望更改代码中工作表的名称。

 Option Explicit Private Sub CommandButton1_Click() ' 14 Nov 2017 Dim Ws As Worksheet Dim ClmCount As Long Dim SortYear As Long ' = column in main table Dim SortOrder As XlSortOrder Dim Rng As Range Dim Rl As Long, Rend As Long ' last row Dim R As Long, C As Long Set Ws = Worksheets("Deepak") SortYear = YearToSort(Ws) If SortYear Then ' exit if cancelled Application.ScreenUpdating = False With Ws Rl = .Cells(.Rows.Count, "A").End(xlUp).Row If Rl > 3 Then ' skip, if no list ClmCount = MainTableColumnsCount(Ws) ' === Sorting the main table ' you can sort on another column, in another order ' or skip the sort entirely ' to skip remove these two lines of code Set Rng = Range(.Cells(3, "A"), .Cells(Rl, ClmCount)) SortRange Rng, 1, xlAscending ' sort Main by country (column 1) ' === set the sort order for Lists 1 & 2 here:- SortOrder = xlAscending ' Alt: change for xlDescending SheetSetup Ws, SortYear, SortOrder ' create sorted copies ' List 1: delete all but the top 10 C = ClmCount + 2 R = IIf(SortOrder = xlAscending, 3, 13) Rend = IIf(SortOrder = xlAscending, Rl - 10, Rl) Set Rng = Range(.Cells(R, C), .Cells(Rend, C + ClmCount - 1)) Rng.Delete Shift:=xlUp ' List 2: delete the top 10 C = 2 * (ClmCount + 1) + 1 R = IIf(SortOrder = xlAscending, Rl - 9, 3) Rend = IIf(SortOrder = xlAscending, Rl, 12) Set Rng = Range(.Cells(R, C), .Cells(Rend, C + ClmCount - 1)) Rng.Delete Shift:=xlUp ' write totals Rl = .Cells(.Rows.Count, C).End(xlUp).Row With .Cells(Rl + 1, C) .Value = "Remaining" .HorizontalAlignment = xlRight .Font.Bold = True End With For C = (C + 1) To (C + ClmCount - 1) Set Rng = Range(.Cells(3, C), .Cells(Rl, C)) With .Cells(Rl + 1, C) .Value = Application.Sum(Rng) .HorizontalAlignment = xlCenter .Font.Bold = True End With Next C End If End With Application.ScreenUpdating = True End If End Sub Private Sub SortRange(Rng As Range, _ SortColumn As Long, _ SortOrder As XlSortOrder) ' 14 Nov 2017 With Rng.Worksheet.Sort .SortFields.Clear .SortFields.Add Key:=Rng.Columns(SortColumn), _ SortOn:=xlSortOnValues, _ Order:=SortOrder, _ DataOption:=xlSortNormal .SetRange Rng .Header = xlNo .MatchCase = False .Orientation = xlTopToBottom .SortMethod = xlPinYin .Apply End With End Sub Private Function YearToSort(Ws As Worksheet) As Long ' 14 Nov 2017 ' return the column number of the main table ' return 0 if cancelled Dim Fun As Long Dim Rng As Range Dim UserInput As String Set Rng = Ws.Range(Cells(2, 2), Cells(2, MainTableColumnsCount(Ws))) ' use B2 as default Do UserInput = InputBox("Enter the year to sort by:", _ "Select a year", Rng.Cells(1).Value) If UserInput = "" Then Exit Do On Error Resume Next Fun = Application.Match(CLng(UserInput), Rng, 0) If Err Then MsgBox "There is no data for year " & UserInput & "." & vbCr & _ "Please enter an available year.", _ vbInformation, "Invalid input" UserInput = "" On Error GoTo 0 End If Loop While UserInput = "" YearToSort = Fun + 1 End Function Private Sub SheetSetup(Ws As Worksheet, _ SortYear As Long, _ SortOrder As XlSortOrder) ' 14 Nov 2017 Const Captions As String = "Top 10 countries,All other countries" Dim Rng As Range, SortRng As Range Dim ClmCount As Long Dim Rl As Long ' last row Dim C As Long Dim i As Long With Ws Rl = .Cells(.Rows.Count, 1).End(xlUp).Row ClmCount = MainTableColumnsCount(Ws) C = .UsedRange.Columns.Count If C > ClmCount Then ' delete all existing except main table Set Rng = Range(.Cells(1, ClmCount + 1), .Cells(Rl, C)) Rng.Cells.Delete Shift:=xlUp End If Set Rng = Range(.Cells(1, 1), .Cells(Rl, ClmCount)) ' create two copies of the main table For i = 1 To 2 C = (ClmCount + 1) * i + 1 Rng.Copy Destination:=.Cells(1, C) .Cells(1, C + 1).Value = Split(Captions, ",")(i - 1) Set SortRng = Range(.Cells(3, C), .Cells(Rl, C + ClmCount - 1)) SortRange SortRng, SortYear, SortOrder Next i End With End Sub Private Function MainTableColumnsCount(Ws As Worksheet) As Long ' 14 Nov 2017 Dim Fun As Long Do Fun = Fun + 1 Loop While Len(Ws.Cells(2, Fun).Value) MainTableColumnsCount = Fun - 1 End Function 

Answer 4

你也可以用公式来做。 在G3细胞types中：

 =LARGE(C$3:C$200, ROW()-2) 

寻找最大的国家。 在F3和E3中插入：

 =INDEX(B$3:B$200, MATCH(G3,C$3:C$200,0)) 

和

 =INDEX(A$3:A$200, MATCH(G3,C$3:C$200,0)) 

分别。 然后拖动到第12行。 你现在排名前十。 在单元格K3中：

 =IFERROR(LARGE(C$3:C$200, ROW()+8),"") 

在J3和I3中：

 =IFERROR(INDEX(B$3:B$200, MATCH(K3,C$3:C$200,0)),"") 

和

 =IFERROR(INDEX(A$3:A$200, MATCH(K3,C$3:C$200,0)),"") 

然后拖动几个屏幕。 世界上有不到200个国家和地区，所以应该够了。 如果没有macros，你不需要button，一切都会更新。