如何在Excel中使用VBA合并两行（或多行）？

我正在尝试使用VBA合并Excel中的两行，以便使用因子x创建具有选定行组合值的新行

alpha 5 6 8 3 ...
beta 10 1 5 7 ...

对于alpha和beta，我想创建行ab70（x=.7）

我想从VBA中的GUI中创建它，从列表中选择材质并选择因子x

谢谢：D

---

L

这个答案的第一个版本更关心的是澄清要求，而不是回答问题。第二个版本更接近正确答案。删除了在评论中回答的第一版中的问题

删除问题后的第一版

这不是一个可以教您创建用户表单的网站，尽管您可以获得控件代码的帮助。尝试在web上搜索“excel vba用户表单教程”。有一个数字可供选择。我没有试过，所以不能推荐

列表框允许程序提供一个列表，用户可以从中选择一个或多个项目。组合框允许程序提供一个列表，用户可以从中选择一个项目或输入不在列表中的新值。您不希望用户能够指定自己的材质，因此需要一个列表框。默认情况下，用户只能选择一个您想要的项目

第二版

这不是一个完整的答案。我会给你设计的想法，然后你可以发展，以满足你的确切要求，或者你可以澄清你的要求，我会发展他们多一点。我将给您一些有用的代码，但不是完整解决方案所需的全部代码

你说结合两种材料可以满足你当前的需要，但从长远来看，你希望结合更多。解决这种情况有不同的方法：

设计并实施一个解决方案，以满足当前需要。为以后的长期规划重新设计

现在就为长期需要设计并实施解决方案

设计一个长期的解决方案，然后实施尽可能多的长期设计

这些方法中没有一种在任何情况下都是正确的。如果你工作到最后期限，方法1很多是唯一的选择。如果您缺乏该技术的经验，并且希望将简单的实现作为培训练习，那么方法1也可能是合适的。在我年轻的时候，向多个用户分发应用程序的新版本可能会非常昂贵，方法2通常是首选方法。这些天来，我通常喜欢方法3

根据你的评论，我推断你在想：

这两个列表框中填充了材质的名称，因此用户可以单击第一个列表框中的一行和第二个列表框中的一行来指定这两种材质。文本框允许用户输入比例和名称。我使用蓝色的“Rem”表示您可能希望显示为注释的剩余部分（1–x）。你可能没有想到纽扣。如果用户无意中启动了宏，则应该始终有一个退出按钮。单击一个按钮保存混合物允许用户首先检查四个值

我认为这可能是一个优秀的设计为两种材料的版本。如果我们忽略行的实际合并，那么表单后面的代码就很少了

我不知道你的材料名称有多长，但我假设这个设计可以扩展为三到四种材料，在右边添加额外的列表框，在所有材料下添加一个比例文本框，但最后一个列表除外。然而，这种安排将有一个低的最大数量的材料的混合物。如果您的最大值较低，这是可以接受的。您还可以允许用户混合混合物，从而允许混合物中含有无限数量的基材

一个允许混合三到四种材料的表单背后的代码只比两种材料版本背后的代码稍微复杂一点

我有两个备选设计，如果材料的最大数量更高，可能会更好，但除非您指出第一个设计是不可接受的，否则不会概述

我希望任何好的教程都能解释加载带有值的列表框的各种方法，我不会重复它们

---

无论您决定如何处理材质及其比例的选择，都需要一个例程来生成新行

我创建了一个工作表“Material”，并将前几行和前几列设置为：

我感谢您有更多的行和列，但我的数据足以进行测试和演示。注：标题行“Prop”是“Property”的缩写

您需要告诉例程哪些行合并，哪些行要混合。用户将选择材质。您可以将“B2”传递给例程，让它发现它所来自的行，但这会使例程编写起来比必要的更困难。从该工作表加载列表框时，值将取自第2行至第12行的A列。我希望您的用户表单教程能够解释，您的代码可以通过值（B2）或索引（第4行）识别用户选择的值。您知道列表框的第一行是从工作表的第2行加载的，因此您可以计算列表框的第四行是从工作表的第5行加载的

您需要告诉例程用户输入的比例和混合物的名称

上面我列出了三种可能的方法来决定要实现多少。除了这些方法之外，还包括了一些灵活性，这些灵活性不是必需的，但与排除灵活性一样容易，或者说包括灵活性比排除灵活性更容易

我的例行程序声明如下：

Sub RecordNewMixture(ByVal WshtName, ByRef RowSrc() As Long, ByRef Prop() As Single, _
                     ByVal MaterialNameNew As String) 

你只需要穿上

Sub RecordNewMixture(ByVal WshtName, ByRef RowSrc() As Long, ByRef Prop() As Single, _
                     ByVal MaterialNameNew As String) 

Option Explicit
Sub Test()

  Dim RowSrc() As Long
  Dim Prop() As Single

  ReDim RowSrc(0 To 1)
  ReDim Prop(0 To 1)

  RowSrc(0) = 2:   Prop(0) = 0.7!
  RowSrc(1) = 4:   Prop(1) = 0.3!

  Call RecordNewMixture("Material", RowSrc, Prop, "Join24")

  ReDim RowSrc(1 To 3)
  ReDim Prop(1 To 3)

  RowSrc(1) = 3:   Prop(1) = 0.3!
  RowSrc(2) = 6:   Prop(2) = 0.3!
  RowSrc(3) = 9:   Prop(3) = 0.4!

  Call RecordNewMixture("Material", RowSrc, Prop, "Join369")

End Sub
Sub RecordNewMixture(ByVal WshtName, ByRef RowSrc() As Long, ByRef Prop() As Single, _
                     ByVal MaterialNameNew As String)

  ' * RowSrc is an array containing the numbers of the rows in worksheet WshtName
  '   that are to be mixed to create a new material.
  ' * Prop is an array containing the proportions of each source material in the new
  '   mixture.
  ' * Arrays RowSrc and Prop must have the same lower and upper bounds.
  ' * MaterialNameNew is the name of the mixture.
  ' * Each data row in Worksheet WshtName defines a material. Column A contains the
  '   name of the material. The remaining columns contain numeric properties of the
  '   material.
  '   Each data row in Worksheet WshtName must have the same maximum number of
  '   columns. Call this value ColLast.
  ' * This routine creates a new row below any existing rows within worksheet
  '   WshtName.  Call this row RowNew. The values in this new row are:
  '    * Column A = MaterialNameNew
  '    * For ColCrnt = 2 to ColMax
  '    *   Cell(RowNew, ColCrnt) = Sum of Cell(RowSrc(N), ColCrnt) * Prop(N)
  '                                for N = LBound(RowSrc) to UBound(RowSrc)

  Dim ColCrnt As Long
  Dim ColLast As Long
  Dim InxRowSrc As Long
  Dim RowNew As Long
  Dim ValueNewCrnt As Single

  Application.ScreenUpdating = False

  With Worksheets(WshtName)

    ' Locate the row before the last row with a value in column A
    RowNew = .Cells(Rows.Count, "A").End(xlUp).Row + 1

    ' Store name of new material
    .Cells(RowNew, "A") = MaterialNameNew

    ' Locate the last column in the first source row.  Assume same
    ' last column for all other source rows
    ColLast = .Cells(RowSrc(LBound(RowSrc)), Columns.Count).End(xlToLeft).Column

    For ColCrnt = 2 To ColLast
      ' If Single does not give adequate precision, change the declaration of
      ' Prop() and ValueNewCrnt to Double. If you do this, replace "0!" by "0#"
      ValueNewCrnt = 0!
      For InxRowSrc = LBound(RowSrc) To UBound(RowSrc)
        ValueNewCrnt = ValueNewCrnt + .Cells(RowSrc(InxRowSrc), ColCrnt).Value * Prop(InxRowSrc)
      Next
      .Cells(RowNew, ColCrnt) = ValueNewCrnt
    Next

  End With

  Application.ScreenUpdating = True

End Sub