Merge Two Columns of Data into a Single Variable - excel

Question

I have a spreadsheet with two columns of data, both columns have a header. I would like to establish a variable for each row of data I can then use to generate new worksheet names and insert into formulas. My variable would be a one to one ratio with the data, meaning A2-B2, A3-B3, etc. I have tried the following code:
'''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'''
However, this code generates a variable with all of the possible combinations (A2-B2, A2-B3, A3-B3, etc.). Ideally, this code would also skip empty cells and not create a variable for that entire row. Here is a screenshot of my sample dataset.Sample Dataset. Thank you for the assistance.

Answer 1

Add Worksheets with Names Created from Two Columns
I see the double Application.InputBoxes as a disaster waiting to happen so I abandoned the idea.
The code will search for the specified headers in the first row and their columns will define the column ranges (from the 2nd to the last row).
Copy the code into a standard module, e.g. Module1.
Adjust the four constants.
You only run the first procedure which will call the second when needed.
The third procedure is showing an example of proper error handling. Study it closely.
The Code
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
Proper Error Handling
Sub ProperErrorHandling()
On Error GoTo ErrorHandling
' The code
ProcExit:
Exit Sub ' You don't want to show the message if no error and
' you must not 'Resume' with no error!
ErrorHandling:
MsgBox Prompt:="Error Detected" & vbNewLine & "Error '" & Err.Number _
& "': " & Err.Description, _
Buttons:=vbCritical, _
Title:="Fail"
' Sets the error number to 0, but still keeps the error handler active.
' Therefore be aware that if you put code between 'ProcExit' and 'Exit Sub'
' and an error occurs, it will result in an endless loop.
Resume ProcExit ' 'Resume', not 'GoTo'!
End Sub

Answer 2

Please try this code.
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

Answer 3

I think it's best
loop through rngBP range not empty values, only
using a Dictionary object to ensure you're not duplicating sheet names
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