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

Question

我正在尝试使用VBA合并Excel中的两行，以便使用因子x创建一个包含所选行组合值的新行。

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

使用alpha和beta我想创建行ab70（x = .7）

ab70 6.5 4.5 7.1 4.2 ...
(5*.7+10(1-.7)) ...

我想从VBA中的GUI创建这个，从列表中选择材料并选择因子x。

谢谢：D L

Answer 1

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

删除问题后的第一个版本

虽然您可以获得有关控件代码的帮助，但这不是一个可以教您创建用户窗体的网站。尝试在网上搜索“excel vba userform tutorial”。有一些可供选择。我没有尝试任何，所以无法提出建议。

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

第二版

这不是一个完整的答案。我会给你一些设计思路，然后你可以根据你的具体要求进行开发，或者你可以澄清你的要求，我会再开发一些。我会给你一些有用的代码，但并不是你需要完整的解决方案。

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

1. 立即设计并实施解决方案。稍后重新设计。
2. 为长期需求设计并实施解决方案。
3. 长期设计解决方案，然后尽可能多地实施长期设计。

在所有情况下，这些方法都不正确。如果您在截止日期前工作，那么很多方法都是唯一的选择。如果您缺乏技术经验并希望将简单实施作为培训练习，方法1也可能是合适的。当我年轻时，向多个用户分发新版本的应用程序可能非常昂贵，而方法2通常是首选方法。这些天，方法3通常是我的偏好。

从您的评论中我推断出您正在考虑以下内容：



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

我认为这可能是两种材料版本的出色设计。如果我们忽略行的实际合并，那么这个表单背后会有很少的代码。

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

允许混合使用三种或四种材料的表格背后的代码只比两种材料版本后面的代码复杂一点。

我有两种替代设计，如果材料的最大数量更多可能会更好，但除非你指出第一种设计是不可接受的，否则它不会勾勒出来。

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

---

但是，您决定处理材料及其比例的选择，您需要一个例程来生成新行。

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



我感谢您拥有更多行和列，但我的数据足以进行测试和演示。请注意标题行＆＃34; Prop＆＃34;是＆＃34; Property＆＃34;。

的缩写

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

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

上面我列出了三种可能的方法来决定实施多少。任何这些方法的补充是包含不需要的灵活性，但是比排除更容易或更容易包括。

我的例程声明是：

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

您将只有一个工作表持有材料，其名称不太可能改变，因此我可以将该工作表的名称硬编码到例程中。但是，将工作表名称作为参数几乎一样容易，我认为它使代码更加整洁，所以我将其作为参数。

例程需要数组Prop（）包含所有比例，包括最后一个。因此，例如，（0.7,0.3）或（0.3,0.3,0.4）。用户表单必须计算最后一个比例，以便它可以通过最后一个比例。我已经使Prop（）成为一个Singles数组，我认为它会给你足够的精度。如果你不理解我能解释的最后一句话。请注意，这里＆＃34; Prop＆＃34;比例很小。很抱歉使用＆＃34;道具＆＃34;作为＆＃34; Property＆＃34;的缩写。和＆＃34;比例＆＃34;。在我最后检查这段文字之前，我没有注意到。

我需要一个例程来测试Sub RecordNewMixture所以我已经提供了它作为演示。请注意，我已经编写并测试了此例程，而没有任何用户表单的参与。在将它们组合到成品中之前，最好单独开发和测试您的例程。

运行宏后，工作表“Material”有两个新行：



如果您使用公式复制新行，您会发现这些值符合您的要求。

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