Excel 将两列数据合并到单个变量中

我有一个有两列数据的电子表格，两列都有一个标题。我想为每一行数据建立一个变量，然后用它生成新的工作表名称并插入公式。我的变量与数据的比率为一比一，表示A2-B2、A3-B3等。我尝试了以下代码：

 '''Sub CreateSheet2()

 Dim rngBP As Range
 Dim rngCon As Range
 Dim cellBP As Range
 Dim cellCon As Range

 On Error GoTo Errorhandling

 Set rngBP = Application.InputBox(prompt:="Bid Package Select Cell Range:", Title:="Create Sheets", Default:=Selection.Address, Type:=8)
 Set rngCon = Application.InputBox(prompt:="Contractor Select Cell Range:", Title:="Create Sheets", Default:=Selection.Address, Type:=8)

For Each cellBP In rngBP
    
        If cellBP <> "" And cellCon <> "" Then
            
            Sheets.Add(after:=ActiveWorkbook.Worksheets(ActiveWorkbook.Worksheets.Count)).Name = cellBP & "-" & cellCon
    
        End If
    
Next cellBP

Errorhandling:

     MsgBox prompt:="Error Detected" & vbNewLine & "Error" & Err.Number & ": " & Err.Description

End Sub'''

''Sub-CreateSheet2（）
Dim rngBP As范围
Dim rngCon As范围
变暗单元格作为范围
Dim cellCon As系列
关于错误转到错误处理
设置rngBP=Application.InputBox（提示：=“投标包选择单元格范围：”，标题：=“创建工作表”，默认值：=Selection.Address，类型：=8）
设置rngCon=Application.InputBox（提示：=“承包商选择单元格范围：”，标题：=“创建工作表”，默认值：=Selection.Address，类型：=8）
对于rngBP中的每个cellBP
如果cellBP“”和cellCon“”，则
Sheets.Add（在：=active工作簿.Worksheets（active工作簿.Worksheets.Count）之后）。Name=cellBP&“-”&cellCon
如果结束
下一个细胞
错误处理：
MsgBox提示符：=“检测到错误”&vbNewLine&“错误”&errr.Number&“：”&Err.Description
结束子节点“”'

但是，此代码生成一个包含所有可能组合（A2-B2、A2-B3、A3-B3等）的变量。理想情况下，此代码还将跳过空单元格，而不是为整行创建变量。这是我的示例数据集的屏幕截图。。谢谢您的帮助。

请尝试此代码

Sub CreateSheet2()

    Const BidPack       As String = "A"         ' specify a column
    Const Contractor    As String = "B"         ' change to suit (to the right of BidPack)
    Const FirstDataRow  As Long = 2             ' change to suit
    
    Dim Wb              As Workbook
    Dim Ws              As Worksheet
    Dim BidRng          As Range
    Dim ConRng          As Range
    Dim Tmp             As Variant              ' misc use
    Dim WsName          As String
    Dim R               As Long                 ' loop counter: rows
    
    Set Wb = ActiveWorkbook                     ' change to suit
    WsName = "Sheet1"                           ' change to suit
    Application.ScreenUpdating = False
    Tmp = Columns(Contractor).Column
    With Wb.Worksheets(WsName)
        Set ConRng = .Range(.Cells(FirstDataRow, Tmp), _
                            .Cells(.Rows.Count, Tmp).End(xlUp))
        ' ConRng and BidRng are of identical size,
        ' not exceeding the number of rows available in ConRng.
        Set BidRng = ConRng.Offset(, Columns(BidPack).Column - Tmp)
        
        For R = 1 To BidRng.Cells.Count
            If (Not IsEmpty(BidRng.Cells(R))) And (Not IsEmpty(ConRng.Cells(R))) Then
                WsName = Format(BidRng.Cells(R).Value, "00-") & ConRng.Cells(R).Value
                On Error Resume Next
                Set Tmp = Wb.Sheets(WsName)
                If Err Then
                    Wb.Sheets.Add(After:=Wb.Sheets(Wb.Sheets.Count)).Name = WsName
                Else
                    MsgBox "A worksheet by the name of """ & WsName & _
                           """ already exists.", vbInformation, _
                           "Duplicate instruction"
                End If
            End If
        Next R
    End With
    Application.ScreenUpdating = False
End Sub

请尝试此代码

Sub CreateSheet2()

    Const BidPack       As String = "A"         ' specify a column
    Const Contractor    As String = "B"         ' change to suit (to the right of BidPack)
    Const FirstDataRow  As Long = 2             ' change to suit
    
    Dim Wb              As Workbook
    Dim Ws              As Worksheet
    Dim BidRng          As Range
    Dim ConRng          As Range
    Dim Tmp             As Variant              ' misc use
    Dim WsName          As String
    Dim R               As Long                 ' loop counter: rows
    
    Set Wb = ActiveWorkbook                     ' change to suit
    WsName = "Sheet1"                           ' change to suit
    Application.ScreenUpdating = False
    Tmp = Columns(Contractor).Column
    With Wb.Worksheets(WsName)
        Set ConRng = .Range(.Cells(FirstDataRow, Tmp), _
                            .Cells(.Rows.Count, Tmp).End(xlUp))
        ' ConRng and BidRng are of identical size,
        ' not exceeding the number of rows available in ConRng.
        Set BidRng = ConRng.Offset(, Columns(BidPack).Column - Tmp)
        
        For R = 1 To BidRng.Cells.Count
            If (Not IsEmpty(BidRng.Cells(R))) And (Not IsEmpty(ConRng.Cells(R))) Then
                WsName = Format(BidRng.Cells(R).Value, "00-") & ConRng.Cells(R).Value
                On Error Resume Next
                Set Tmp = Wb.Sheets(WsName)
                If Err Then
                    Wb.Sheets.Add(After:=Wb.Sheets(Wb.Sheets.Count)).Name = WsName
                Else
                    MsgBox "A worksheet by the name of """ & WsName & _
                           """ already exists.", vbInformation, _
                           "Duplicate instruction"
                End If
            End If
        Next R
    End With
    Application.ScreenUpdating = False
End Sub

添加具有从两列创建的名称的工作表

• 我认为double

  应用程序。inputboxs

  是一场即将发生的灾难，所以我放弃了这个想法
• 代码将在第一行中搜索指定的标题，其列将定义列范围（从第二行到最后一行）
• 将代码复制到标准模块，例如

  模块1

• 调整四个常数
• 您只运行第一个过程，该过程将在需要时调用第二个过程
• 第三个过程是显示正确错误处理的示例。仔细研究一下

代码

Option Explicit

Sub CreateSheet2()

    'On Error GoTo ErrorHandling
    
    Const wsName As String = "Sheet1"
    Const bTitle As String = "Bid Package"
    Const cTitle As String = "Contractor"
    Const FirstRow As Long = 2
    
    Dim wb As Workbook
    Set wb = ThisWorkbook ' The workbook containing this code.
    
    Dim ws As Worksheet
    Set ws = wb.Worksheets(wsName)
    
    Dim bCol As Variant
    bCol = Application.Match(bTitle, ws.Rows(1), 0)
    
    Dim cCol As Variant
    cCol = Application.Match(cTitle, ws.Rows(1), 0)
    
    Dim LastRow As Long
    LastRow = ws.Cells(ws.Rows.Count, bCol).End(xlUp).Row
    
    Dim ColumnOffset As Long
    ColumnOffset = cCol - bCol
    
    Dim SheetNames As Variant
    SheetNames = getSheetNames(wb)
    
    Dim rng As Range
    Set rng = ws.Cells(FirstRow, bCol).Resize(LastRow - FirstRow + 1)
    
    Dim cel As Range
    Dim SheetName As String
    
    For Each cel In rng.Cells
        If cel.Value <> "" And cel.Offset(, ColumnOffset).Value <> "" Then
            SheetName = cel.Value & "-" & cel.Offset(, ColumnOffset).Value
            If IsError(Application.Match(SheetName, SheetNames, 0)) Then
                On Error Resume Next
                wb.Worksheets.Add(After:=wb.Sheets(wb.Sheets.Count)).Name _
                  = SheetName
                If Err Then ' might happen if there are duplicates in columns.
                    Application.DisplayAlerts = False
                    ActiveSheet.Delete
                    Application.DisplayAlerts = True
                End If
                On Error GoTo ErrorHandling
            End If
        End If
    Next cel
    
ProcExit:
    Exit Sub

ErrorHandling:
    MsgBox Prompt:="Error Detected" & vbNewLine & "Error '" & Err.Number _
                 & "': " & Err.Description, _
           Buttons:=vbCritical, _
           Title:="Fail"
    Resume ProcExit

End Sub

Function getSheetNames(Book As Workbook) _
  As Variant
    
    If Book Is Nothing Then
        GoTo ProcExit
    End If
    
    Dim Data As Variant
    ReDim Data(1 To Book.Sheets.Count)
    
    Dim sh As Object
    Dim n As Long
    
    For Each sh In Book.Sheets
        n = n + 1
        Data(n) = sh.Name
    Next sh
    
    getSheetNames = Data

ProcExit:

End Function

添加具有从两列创建的名称的工作表

• 我认为double

  应用程序。inputboxs

  是一场即将发生的灾难，所以我放弃了这个想法
• 代码将在第一行中搜索指定的标题，其列将定义列范围（从第二行到最后一行）
• 将代码复制到标准模块，例如

  模块1

• 调整四个常数
• 您只运行第一个过程，该过程将在需要时调用第二个过程
• 第三个过程是显示正确错误处理的示例。仔细研究一下

代码

Option Explicit

Sub CreateSheet2()

    'On Error GoTo ErrorHandling
    
    Const wsName As String = "Sheet1"
    Const bTitle As String = "Bid Package"
    Const cTitle As String = "Contractor"
    Const FirstRow As Long = 2
    
    Dim wb As Workbook
    Set wb = ThisWorkbook ' The workbook containing this code.
    
    Dim ws As Worksheet
    Set ws = wb.Worksheets(wsName)
    
    Dim bCol As Variant
    bCol = Application.Match(bTitle, ws.Rows(1), 0)
    
    Dim cCol As Variant
    cCol = Application.Match(cTitle, ws.Rows(1), 0)
    
    Dim LastRow As Long
    LastRow = ws.Cells(ws.Rows.Count, bCol).End(xlUp).Row
    
    Dim ColumnOffset As Long
    ColumnOffset = cCol - bCol
    
    Dim SheetNames As Variant
    SheetNames = getSheetNames(wb)
    
    Dim rng As Range
    Set rng = ws.Cells(FirstRow, bCol).Resize(LastRow - FirstRow + 1)
    
    Dim cel As Range
    Dim SheetName As String
    
    For Each cel In rng.Cells
        If cel.Value <> "" And cel.Offset(, ColumnOffset).Value <> "" Then
            SheetName = cel.Value & "-" & cel.Offset(, ColumnOffset).Value
            If IsError(Application.Match(SheetName, SheetNames, 0)) Then
                On Error Resume Next
                wb.Worksheets.Add(After:=wb.Sheets(wb.Sheets.Count)).Name _
                  = SheetName
                If Err Then ' might happen if there are duplicates in columns.
                    Application.DisplayAlerts = False
                    ActiveSheet.Delete
                    Application.DisplayAlerts = True
                End If
                On Error GoTo ErrorHandling
            End If
        End If
    Next cel
    
ProcExit:
    Exit Sub

ErrorHandling:
    MsgBox Prompt:="Error Detected" & vbNewLine & "Error '" & Err.Number _
                 & "': " & Err.Description, _
           Buttons:=vbCritical, _
           Title:="Fail"
    Resume ProcExit

End Sub

Function getSheetNames(Book As Workbook) _
  As Variant
    
    If Book Is Nothing Then
        GoTo ProcExit
    End If
    
    Dim Data As Variant
    ReDim Data(1 To Book.Sheets.Count)
    
    Dim sh As Object
    Dim n As Long
    
    For Each sh In Book.Sheets
        n = n + 1
        Data(n) = sh.Name
    Next sh
    
    getSheetNames = Data

ProcExit:

End Function

我认为这是最好的

• 循环通过

  rngBP

  范围仅限非空值

• 使用

  字典

  对象确保没有重复工作表名称

   Option Explicit
  
  
   Sub CreateSheets()
  
   Dim rngBP As Range
   Dim cellBP As Range
  
   On Error GoTo Errorhandling
  
   Set rngBP = Application.InputBox(prompt:="Bid Package Select Cell Range:", Title:="Create Sheets", Default:=Selection.Address, Type:=8)
  
  
   Dim shNamesDict As Object
   Set shNamesDict = CreateObject("Scripting.Dictionary")
  
   With ActiveWorkbook
       Dim shName As String
       For Each cellBP In rngBP.SpecialCells(xlCellTypeConstants)
  
           If Not IsEmpty(cellBP.Offset(, 1).Value2) Then
               shName = cellBP.Value2 & "-" & cellBP.Offset(, 1).Value2
               If Not shNamesDict.exists(shName) Then
                   shNamesDict.Add shName, 0
                   .Sheets.Add(after:=.Worksheets(.Worksheets.Count)).Name = shName
               End If
           End If
       Next
   End With
  
  
   Errorhandling:
  
   If Err.Number <> 0 Then MsgBox prompt:="Error Detected" & vbNewLine & "Error" & Err.Number & ": " & Err.Description
  
   End Sub
  

  选项显式
  子工作表（）
  Dim rngBP As范围
  变暗单元格作为范围
  关于错误转到错误处理
  设置rngBP=Application.InputBox（提示：=“投标包选择单元格范围：”，标题：=“创建工作表”，默认值：=Selection.Address，类型：=8）
  Dim shNamesDict作为对象
  Set shnamedict=CreateObject（“Scripting.Dictionary”）
  使用ActiveWorkbook
  将名称设置为字符串
  对于rngBP.SpecialCells中的每个cellBP（xlCellTypeConstants）
  如果不是IsEmpty（cellBP.Offset（，1）.Value2），则
  shName=cellBP.Value2&“-”和cellBP.Offset（，1）.Value2
  如果shNamesDict.不存在（shName），则
  shNamesDict。添加shName，0
  .Sheets.Add（后面：=.Worksheets（.Worksheets.Count））.Name=shName
  如果结束
  如果结束
  下一个
  以
  错误处理：
  如果错误号为0，则MsgBox提示符：=“检测到错误”&vbNewLine&“错误”&errr.Number&“：”&Err.Description
  端接头
  

我认为这是最好的
• 循环通过

  rngBP

  范围仅限非空值

• 使用

  字典

  对象确保没有重复工作表名称

   Option Explicit
  
  
   Sub CreateSheets()
  
   Dim rngBP As Range
   Dim cellBP As Range
  
   On Error GoTo Errorhandling
  
   Set rngBP = Application.InputBox(prompt:="Bid Package Select Cell Range:", Title:="Create Sheets", Default:=Selection.Address, Type:=8)
  
  
   Dim shNamesDict As Object
   Set shNamesDict = CreateObject("Scripting.Dictionary")
  
   With ActiveWorkbook
       Dim shName As String
       For Each cellBP In rngBP.SpecialCells(xlCellTypeConstants)
  
           If Not IsEmpty(cellBP.Offset(, 1).Value2) Then
               shName = cellBP.Value2 & "-" & cellBP.Offset(, 1).Value2
               If Not shNamesDict.exists(shName) Then
                   shNamesDict.Add shName, 0
                   .Sheets.Add(after:=.Worksheets(.Worksheets.Count)).Name = shName
               End If
           End If
       Next
   End With
  
  
   Errorhandling:
  
   If Err.Number <> 0 Then MsgBox prompt:="Error Detected" & vbNewLine & "Error" & Err.Number & ": " & Err.Description
  
   End Sub
  

  选项显式
  子工作表（）
  Dim rngBP As范围
  变暗单元格作为范围
  关于错误转到错误处理
  设置rngBP=Application.InputBox（提示：=“投标包选择单元格范围：”，标题：=“创建工作表”，默认值：=Selection.Address，类型：=8）
  Dim shNamesDict作为对象
  Set shnamedict=CreateObject（“Scripting.Dictionary”）
  使用ActiveWorkbook
  将名称设置为字符串
  对于rngBP.SpecialCells中的每个cellBP（xlCellTypeConstants）
  如果不是IsEmpty（cellBP.Offset（，1）.Value2），则
  shName=cellBP.Value2&“-”和cellBP.Offset（，1）.Value2
  如果shNamesDict.不存在（shName），则
  shNamesDict。添加shName，0
  .Sheets.Add（后面：=.Worksheets（.Worksheets.Count））.Name=shName
  如果结束
  如果结束
  下一个
  以
  错误处理：
  如果错误号为0，则MsgBox提示符：=“检测到错误”&vbNewLine&“错误”&errr.Number&“：”&Err.Description
  端接头
  

---

如果您知道

承包商

列在

BidPackage

列的旁边，为什么需要第二个

应用程序。输入框

？如果

投标包选择单元格范围

，。你为什么要为每个人做

？您是否允许例如a
A2、B3
组合？请澄清。@VBASIC208我不确定我是否理解您的意思，询问是否知道承包商栏是否位于BP栏旁边，您能否澄清？我假设我需要第二个输入范围来捕获Contractor列。我还假设需要使用For-Each循环遍历范围变量。对于您的最后一个问题，A1B1或A2B2之外的组合是不允许的。数据将严格锁定到相邻单元。