Failing to skip empty cells in a VBA Combination creator - excel

I am not too experienced in VBA but found a code online that creates combinations in an excel sheet. This is great except, I need a rule in there that it should skip cells in the combination generator when empty. I tried a couple setups but it kept giving me the same result over and over.
So if i have the following table:
Table 1
Table 2
1
a
b
3
c
The outcome should result in:
1-a
1-b
1-c
3-a
3-b
3-c
However, it leads to:
1-a
1-b
1-c
-a
-b
-c
3-a
3-b
3-c
Anyone can give me a tip or idea to see if this can be solved? Would love to know what is possible before investing too much time in it. Find the VBA below. Thanks in advance!
Sub CombinationGenerator()
Dim xDRg1, xDRg2, xDRg3 As Range
Dim xRg As Range
Dim xStr As String
Dim xFN1, xFN2, xFN3 As Integer
Dim xSV1, xSV2, xSV3 As String
Set xDRg1 = Range("A2:A6") 'First column data
Set xDRg2 = Range("B2:B2") 'Second column data
Set xDRg3 = Range("C2:C2") 'Third column data
xStr = "-" 'Separator
Set xRg = Range("E2") 'Output cell
'Creating combinations
For xFN1 = 1 To xDRg1.Count
If Cells(xFN1, "A") <> "" Then 'Ignore empty cells
xSV1 = xDRg1.Item(xFN1).Text
For xFN2 = 1 To xDRg2.Count
xSV2 = xDRg2.Item(xFN2).Text
For xFN3 = 1 To xDRg3.Count
xSV3 = xDRg3.Item(xFN3).Text
xRg.Value = xSV1 & xStr & xSV2 & xStr & xSV3
Set xRg = xRg.Offset(1, 0)
Next
Next
End If
Next
End Sub

xFN1 iterates from 1 to xDRg1.Cells.Count but the first row of xDRg1 is 2. So when you rebuild the range during the line Cells(xFN1, "A") you're putting 1, 2, 3 instead of 2, 3, 4 for the row numbers.
To avoid confusing code like this, I would suggest switching the For loop to a For Each loop using the Range.Cells collection, meaning the loop element would be a Cell (Range Object) instead of a Row number.
Sub CombinationGenerator()
Dim xDRg1 As Range, xDRg2 As Range, xDRg3 As Range
Dim xRg As Range
Dim xStr As String
Dim xFN1 As Range, xFN2 As Range, xFN3 As Range
Dim xSV1 As String, xSV2 As String, xSV3 As String
Set xDRg1 = Range("A2:A6") 'First column data
Set xDRg2 = Range("B2:B2") 'Second column data
Set xDRg3 = Range("C2:C2") 'Third column data
xStr = "-" 'Separator
Set xRg = Range("E2") 'Output cell
'Creating combinations
For Each xFN1 In xDRg1.Cells
If xFN1 <> "" Then 'Ignore empty cells
xSV1 = xFN1.Text
For Each xFN2 In xDRg2.Cells
xSV2 = xFN2.Text
For Each xFN3 In xDRg3.Cells
xSV3 = xFN3.Text
xRg.Value = xSV1 & xStr & xSV2 & xStr & xSV3
Set xRg = xRg.Offset(1, 0)
Next
Next
End If
Next
End Sub

Related

Set all empty cells to zero except for certain columns

I have a file called "gar_nv", "nbrLines" is the number of lines ,defined in my code. I have given names to my columns. "listCol" is a function returning a list of these names.
I would like to set all empty cells to zero except the cells of the following columns: "GCFRRE", "GCDEP1", "GCDEP2", "GCDEP3", "GCTYC0", "GCTYC1", "GCTYC2", "GCTYC3","GCBAC0", "GCBAC1", "GCBAC2", "GCBAC3". Knowing I have thousands of rows, this code takes a long time to run. Is there a way to make it faster ?
Dim rng As Variant, i As Long
With gar_nv
For i = 1 To nbrLines - 1
For Each rng In ListCol
Select Case rng
Case "GCFRRE", "GCDEP1", "GCDEP2", "GCDEP3", _
"GCTYC0", "GCTYC1", "GCTYC2", "GCTYC3", _
"GCBAC0", "GCBAC1", "GCBAC2", "GCBAC3"
Case Else
If IsEmpty(.range(rng).Rows(i)) = True Then
.range(rng).Rows(i).Value = "0"
End If
End Select
Next rng
Next i
End With
Let's say your columns are named ranges like headers in the image:
You can do:
Sub test()
Application.ScreenUpdating = False
Dim rng As Range
Dim Listcol As Variant
Dim i As Long
Listcol = Array("A", "B", "C_", "D") 'list of all named ranges
For i = 0 To UBound(Listcol)
Select Case Listcol(i)
Case "B"
'we do nothing
Case Else
'we replace blanks with 0
Set rng = Range(Listcol(i)).SpecialCells(xlCellTypeBlanks)
rng.FormulaR1C1 = "=0" ' set them to 0
rng.Value = rng.Value 'replace formula with value
Set rng = Nothing
End Select
Next i
Erase Listcol
Application.ScreenUpdating = True
End Sub
Notice named range B has been excluded:

For loop not looping-Only pulling first value found

I am trying to search a column for cells that contain certain text, and if they do, copy the value next to it and paste in the first free row of an assigned range. Below is the code I am using, it will return the one value but is not looping to return the others.
Const SB As String = "*SB*"
Dim cel As Range
Dim sbcellvalue As Variant
Dim SBpull As Range
Dim SBpaste As Range
Set SBpull = Worksheets("SBImport").Range("Q:Q")
Set SBpaste = Worksheets("Misc").Range("SBRange")
For Each cel In SBpull.Cells
If InStr(1, sbcellvalue, SB, vbTextCompare) > 0 Then
sbcellvalue = cel.Offset(0, 1).Value
SBpaste.Offset(1, 0).End(xlUp) = sbcellvalue
End If
Next cel
MsgBox "search done"
End Sub

VBA Code to Concatenate strings from column if first integers, or first and third integers, in another column match

Alright, this is a very specific question. I have an excel macro written that takes a web URL, delimits it, transposes it, and then adds adjacent columns that describe the information in the originally transposed columns. Now, I need to add something to my macro that will loop through and check if the first character of one cell matches one of the first 4 characters of another cell. If it does, I need to concatenate strings from the descriptive columns to new cells. I'll illustrate this below:
3,435,201,0.5,%22type%25202%2520diabetes%22,0 Node type 2 diabetes
4,165,97,0.5,%22diet%22,0 Node diet
5,149,248,0.5,%22lack%2520of%2520exercise%22,2 Node lack of exercise
6,289,329,0.5,%22genetics%22,3 Node genetics
7,300,71,0.5,%22blood%2520pressure%2520%22,5 Node blood pressure
7,3,-7,1,0 Arrow +
4,3,-21,1,0 Arrow +
5,3,-22,1,0 Arrow +
6,3,-34,1,0 Arrow +
,7%5D Tail
I added color to make the concept of the problem more easily visualized. In row one of the first column, we see a red 3 that corresponds to 'type 2 diabetes'. In the fifth row of the first column, we see a blue 7 that corresponds to 'blood pressure'. These are both node objects, as the adjacent column signifies. In the sixth cell of the first column we see a blue 7 and a red 3. This indicates that an arrow (also signified by adjacent column) is connecting blood pressure to diabetes. In the next column over, we see an orange plus sign, which indicates this is a positive relationship.
The goal is to populate the next column over with "blood pressure + type diabetes", as I demonstrated in the image. So, I need some code to check the first characters in each node cell, and then compare them to the first 4 characters of each arrow cell. When an arrow that matches two of the nodes is found, I need the code to populate the row next to the + signs with a concatenated string comprised of the names of the nodes pertaining to that arrow, as well as the + sign between them (it's possible that it could also be a minus sign, but one isn't present in this example). Any pointers? I can't wrap my head around this. Edited to add Data
Here is the code of my current macro:
Sub Delimit_Transpose()
Cells.Replace What:="],[", Replacement:="#", LookAt:=xlPart, SearchOrder _
:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
ActiveCell.FormulaR1C1 = "=RIGHT(R[-1]C,LEN(R[-1]C)-36)"
Dim i As Long, strTxt As String
Dim startP As Range
Dim xRg As Range, yRg As Range
On Error Resume Next
Set xRg = Application.InputBox _
(Prompt:="Range Selection...", _
Title:="Delimit Transpose", Type:=8)
i = 1
Application.ScreenUpdating = False
For Each yRg In xRg
If i = 1 Then
strTxt = yRg.Text
i = 2
Else
strTxt = strTxt & "," & yRg.Text
End If
Next
Application.ScreenUpdating = True
Set startP = Application.InputBox _
(Prompt:="Paste Range...", _
Title:="Delimit Transpose", Type:=8)
ary = Split(strTxt, "#")
i = 1
Application.ScreenUpdating = False
For Each a In ary
startP(i, 1).Value = Replace(Replace(a, "[", ""), "]", "")
i = i + 1
Next a
i = 1
For Each a In ary
If Len(a) > 13 Then
startP.Offset(i - 1, 1).Value = "Node"
ElseIf Len(a) < 13 And Len(a) > 6 Then
startP.Offset(i - 1, 1).Value = "Arrow"
Else
startP.Offset(i - 1, 1).Value = "Tail"
End If
i = i + 1
Next a
Dim openPos As Integer
Dim closePos As Integer
Dim midBit As String
i = 1
n = 5
For Each a In ary
openPos = InStr(a, ",%22")
On Error Resume Next
closePos = InStr(a, "%22,")
On Error Resume Next
midBit = Mid(a, openPos + 1, closePos - openPos - 1)
On Error Resume Next
If openPos <> 0 And Len(midBit) > 0 Then
startP.Offset(i - 1, 2).Value = Replace(Replace(midBit, "%22", ""), "%2520", " ")
ElseIf Len(a) < 13 And InStr(a, "-") = 4 Then
startP.Offset(i - 1, 2).Value = "'-"
ElseIf Len(a) < 7 Then
startP.Offset(i - 1, 2).Value = " "
Else
startP.Offset(i - 1, 2).Value = "+"
End If
i = i + 1
n = n + 1
Next a
Application.ScreenUpdating = True
End Sub
This is my approach.
There's room for a lot of improvements, but is a rough code that should get you started.
Read the code's comments and adapt it to fit your needs.
EDIT: I updated the code to match the sample worksheet you uploaded, build the first column range dinamically, validate if commas appear in the first column cell so no error is raised.
As I said in the comments, it's better easier to debug if you call one procedure from the other, instead of merging them.
Code:
Option Explicit
Public Sub StoreConcatenate()
' Basic error handling
On Error GoTo CleanFail
' Define general parameters
Dim targetSheetName As String
targetSheetName = "Test space" ' Sheet holding the data
Dim firstColumnLetter As String
firstColumnLetter = "C" ' First column holding the numbers
Dim firstColumnStartRow As Long
firstColumnStartRow = 7
' With these three parameters we'll build the range address holding the first column dynamically
' Set reference to worksheet
Dim targetSheet As Worksheet
Set targetSheet = ThisWorkbook.Worksheets(targetSheetName)
' Find last row in column (Modify on what column)
Dim firstColumnlastRow As Long
firstColumnlastRow = targetSheet.Cells(targetSheet.Rows.Count, firstColumnLetter).End(xlUp).Row
' Build range of first column dinamically
Dim firstColumnRange As Range
Set firstColumnRange = targetSheet.Range(firstColumnLetter & firstColumnStartRow & ":" & firstColumnLetter & firstColumnlastRow)
' Loop through first column range cells
Dim valueCell As Range
For Each valueCell In firstColumnRange
' Check if cell contains "," in the second position in string
If InStr(valueCell.Value, ",") = 2 Then
' Store first digit of cell before ","
Dim firstDigit As Integer
firstDigit = Split(valueCell.Value, ",")(0)
' Check if cell contains "," in the fourth position in string
If InStr(3, valueCell.Value, ",") = 4 Then
' Store second digit of cell after ","
Dim secondDigit As Integer
secondDigit = Split(valueCell.Value, ",")(1)
End If
' Store second colum type
Dim secondColumnType As String
secondColumnType = valueCell.Offset(, 1).Value
' Store third column value
Dim thirdColumnValue As String
thirdColumnValue = valueCell.Offset(, 2).Value
' Store nodes values (first digit and second column type)
Select Case secondColumnType
Case "Node"
Dim nodeValues() As Variant
Dim nodeCounter As Long
ReDim Preserve nodeValues(nodeCounter)
nodeValues(nodeCounter) = Array(firstDigit, thirdColumnValue)
nodeCounter = nodeCounter + 1
Case "Arrow"
Dim matchedNodeFirstValue As String
Dim matchedNodeSecondValue As String
matchedNodeFirstValue = IsInArrayReturnItem(firstDigit, nodeValues)(1)
matchedNodeSecondValue = IsInArrayReturnItem(secondDigit, nodeValues)(1)
If matchedNodeFirstValue <> vbNullString And matchedNodeSecondValue <> vbNullString Then
valueCell.Offset(, 3).Value = matchedNodeFirstValue & Space(1) & thirdColumnValue & Space(1) & matchedNodeSecondValue
End If
End Select
End If
Next valueCell
CleanExit:
Exit Sub
CleanFail:
Debug.Print "Something went wrong: " & Err.Description
Resume CleanExit
End Sub
' Credits: https://stackoverflow.com/a/38268261/1521579
Public Function IsInArrayReturnItem(stringToBeFound As Integer, arr As Variant) As Variant
Dim i
For i = LBound(arr) To UBound(arr)
If arr(i)(0) = stringToBeFound Then
IsInArrayReturnItem = arr(i)
Exit Function
End If
Next i
IsInArrayReturnItem = Array(vbNullString, vbNullString)
End Function
Let me know if it works
It appears that you are concatenating the lookups based on the
first and second integers,
where the second column = "Arrow"
If that is the case, I suggest:
Read the data table into a VBA array for faster processing
I am assuming your data is ordered as you show it, with all the Node entries at the start.
if that is not the case, then loop twice -- once to find the Nodes, and second time to concatenate the Arrow data.
Read the diagnoses into a dictionary for fact lookup.
if column2 = "Arrow" then concatenate the lookups of the first and second integers
Write back the data
Note: As written, this will overwrite the original table destroying any formulas that might be there. If needed, you could easily modify it to only overwrite the necessary area.
Note2 Be sure to set a reference (under Tools/References) to Microsoft Scripting Runtime, or change the Dictionary declaration to late-binding.
Regular Module
'set reference to Microsoft Scripting Runtime
Option Explicit
Sub Dx()
Dim WS As Worksheet
Dim rngData As Range, c As Range, vData As Variant
Dim dDx As Dictionary
Dim I As Long, sKey As String, dxKeys As Variant
'Get the data range
Set WS = ThisWorkbook.Worksheets("sheet1")
With WS
'assume table starts in A1 and is three columns wide
Set rngData = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp)).Resize(columnsize:=3)
'read into variant array for faster processing
vData = rngData
End With
'create dictionsry for dx lookups
Set dDx = New Dictionary
For I = 2 To UBound(vData, 1)
Select Case vData(I, 2)
Case "Node"
sKey = Split(vData(I, 1), ",")(0) 'first comma-separated number
If dDx.Exists(sKey) Then
MsgBox "duplicate diagnostic key. Please correct the data"
Exit Sub
End If
dDx.Add Key:=sKey, Item:=vData(I, 3)
Case "Arrow"
dxKeys = Split(vData(I, 1), ",")
vData(I, 3) = dDx(dxKeys(0)) & " + " & dDx(dxKeys(1))
End Select
Next I
'reWrite the table
Application.ScreenUpdating = False
rngData = vData
End Sub

Excel VBA For each cell in range seems to run through the same cell multiple number of times

The "for-each cell in range" statement seems to be running through the same cell multiple number of times.
See the screenshot.
It runs through the cell that has the word "Product" four time, because it is merged across four rows.
Is there a way to make it run only once, regardless of the design of the worksheet (in other words, I prefer not to use the fact that it is merged across four rows to be taken into account when coding).
Public Sub ProcessBeijingFile(Excel_UNC_Path As String)
Dim src As Workbook
Dim ProdPushWorkbook As Workbook
Set ProdPushWorkbook = ActiveWorkbook
Set src = Workbooks.Open(Excel_UNC_Path, True, True)
Dim c As Range
Dim r As Range
Dim LastRow As Long
Dim text As String
src.Sheets("Page 1").Activate
src.ActiveSheet.Range("A1").Select
LastRow = src.ActiveSheet.Range("A30000").End(xlUp).Row
text = LastRow
text = "A2:BA" + CStr(text)
Set r = Range(text)
Dim i As Integer
For i = 1 To MaxItems
PONumber(i) = ""
Next
Dim PageCounter As Integer
PageCounter = 0
RecordCounter = 0
Dim NextPONumber As String
NextPONumber = ""
For Each c In r
If Left(Trim(c.Value), 5) = "PO No" Then
NextPONumber = Trim(Replace(c.Value, "PO No.:", ""))
NextPONumber = Trim(Replace(NextPONumber, "PO No:", ""))
End If
....
If you don't care about performance and just want simple code, below demonstrates how you can go about skipping MergedCells. It displays address and value of non empty cells from Cell B1 in Immediate window until it reach empty cell. Kind of what you need.
Option Explicit
Sub Sample()
Dim oRng As Range
Set oRng = Range("B1")
Do Until IsEmpty(oRng)
Debug.Print oRng.Address, oRng.Value
Set oRng = oRng.Offset(1)
Loop
Set oRng = Nothing
End Sub
David pointed me in the right direction.
Here is the key:
if c.MergeCells then
If Trim(GetFirstWord(c.MergeArea.Address, ":")) = c.Address Then
'the first of merged cells, then process, else don't process...
Function Needed:
Public Function GetFirstWord(ByVal SearchString As String, Optional ByVal Delimeter As String = " ") As String
If SearchString = "" Then
GetFirstWord = ""
Else
Dim ary As Variant
ary = Split(SearchString, Delimeter)
GetFirstWord = ary(LBound(ary))
End If
' GetFirstWord = ary(LBound(ary))
'GetFirstWord = ary(LBound(ary))
End Function

Excel macro - running through cells on the same level

So I want to run through A1-C200 and paste everything into a Word document. The trouble is, I have two ways of pasting it into Word, but each one has its downfall.
Goal: Copy A1-C200 into Word and keep the column layout, without copying blancs.
Example 1:
The code below copies everything into Word, but runs from A1 -> A200, B1 -> B200, C1 -> C200. Because it reads through my file this way, I lose my column layout. I would prefer a solution for this example, because this code looks clearer to me.
iMaxRow = 200
" Loop through columns and rows"
For iCol = 1 To 3
For iRow = 1 To iMaxRow
With Worksheets("GreatIdea").Cells(iRow, iCol)
" Check that cell is not empty."
If .Value = "" Then
"Nothing in this cell."
"Do nothing."
Else
" Copy the cell to the destination"
.Copy
appWD.Selection.PasteSpecial
End If
End With
Next iRow
Next iCol
Example 2:
The code below copies the correct column layout, but also inserts blancs. So if A1-A5 and A80-A90 are filled in, I will have 75 blancs in my Word document.
a1 = Range("A1").End(xlDown).Address
lastcell = Range("C1").Address
Range(a1, lastcell).Copy
With Range("A1")
Range(.Cells(1, 1), .End(xlDown).Cells(2, 3)).Copy
End With
Range("A1:C50").Copy
appWD.Selection.PasteSpecial
There's multiple ways to do this, don't know which is the quickest but here's some code I threw together real quick for you. Getting the range all at once in a variant is the fastest way to grab data out of excel.
Sub test()
Dim i As Long, j As Long
Dim wd As Word.Document
Dim wdTable As Word.Table
Dim wks As Excel.Worksheet
Dim v1 As Variant
Set wd = GetObject("C:\Documents and Settings\Jon\Desktop\New Microsoft Word Document.doc")
'Get data in array
Set wks = ActiveSheet
v1 = wks.UsedRange
'Create table
Set wdTable = wd.Tables.Add(Range:=wd.Application.Selection.Range, NumRows:=1, NumColumns:= _
ubound(v1,2), DefaultTableBehavior:=wdWord9TableBehavior, AutoFitBehavior:= _
wdAutoFitFixed)
'Place data
For i = 1 To UBound(v1)
For j = 1 To UBound(v1, 2)
If Len(v1(i, j)) > 0 Then
'Add row if not enough rows, this can be done before the j loop if
'you know the first column is always filled.
'You can also do an advanced filter in excel if you know that the first
'column is filled always and filter for filled cells then just
'do a straight copy and paste using r1.specialcells(xlCellTypeVisible).copy
'If you know the rows ahead of time when you create the table you can create all the rows at once,
'which should save time.
wd.application.selection
If wdTable.Rows.Count < i Then wdTable.Rows.Add
wdTable.Cell(i, j).Range.Text = v1(i, j)
End If
Next j
Next i
Set wks = Nothing: Set wd = Nothing: Set v1 = Nothing
End Sub
not quite sure I understand the prob ... but here's a stab at it:
dim rg200x3 as range: set rg200x3 = range("a1:c200")
dim Col1 as new collection
dim Col2 as new collection
dim Col3 as new collection
dim rgRow as new range
dim sText as string
for each rgRow in rg200x3
sText = trim(rgRow.cells(1,1)): if (sText <> "") call Col1.Add(sText)
sText = trim(rgRow.cells(1,2)): if (sText <> "") call Col2.Add(sText)
sText = trim(rgRow.cells(1,3)): if (sText <> "") call Col3.Add(sText)
next rgRow
at this point Col1, Col2, and Col3 contain your text w the blank cells factored out, so now loop over these to print out
dim i as long
for i = 1 to 200
on error resume next ' (cheap way to avoid checking if index > collection sz)
debug.print Col1(i) + " | " Col2(i) + " | " + Col3(i)
on error goto 0
next i
(note: code typed in freehand with no checking ... )
How about this to sub for your first solution:
iMaxRow = 200
" Loop through columns and rows"
For iRow = 1 To iMaxRow
For iCol = 1 To 3
With Worksheets("GreatIdea").Cells(iRow, iCol)
" Check that cell is not empty."
If .Value = "" Then
"Nothing in this cell."
"Do nothing."
Else
"Copy the cell to the destination"
.Copy appWD.Selection.PasteSpecial
End If
End With
Next iCol
Next iRow

Resources