Combine words from columns

B

bojan0810

So I have this code

Sub comb()
Dim a As Range
Dim b As Range
Dim c As Range
Dim d As Range
Dim e As Range
Dim f As Range
Dim g As Range
Dim h As Range
Dim i As Range
Dim j As Range
Dim k As Range
Dim l As Range
Dim m As Range
Dim n As Range
Dim o As Range
Dim p As Range
Dim q As Range
Dim r As Range
Dim s As Range
Dim t As Range

Dim combination As Range
Dim counter
Set combination = Worksheets(1).Range("v:v")
counter = 1
With Worksheets(1)
For Each a In .Range("A2", .Range("A" & .Rows.Count).End(xlUp))
For Each b In .Range("B2", .Range("B" & .Rows.Count).End(xlUp))
For Each c In .Range("c2", .Range("c" & .Rows.Count).End(xlUp))
For Each d In .Range("d2", .Range("d" & .Rows.Count).End(xlUp))
For Each e In .Range("e2", .Range("e" & .Rows.Count).End(xlUp))
For Each f In .Range("f2", .Range("f" & .Rows.Count).End(xlUp))
For Each g In .Range("g2", .Range("g" & .Rows.Count).End(xlUp))
For Each h In .Range("h2", .Range("h" & .Rows.Count).End(xlUp))
For Each i In .Range("i2", .Range("i" & .Rows.Count).End(xlUp))
For Each j In .Range("j2", .Range("j" & .Rows.Count).End(xlUp))
For Each k In .Range("k2", .Range("k" & .Rows.Count).End(xlUp))
For Each l In .Range("l2", .Range("l" & .Rows.Count).End(xlUp))
For Each m In .Range("m2", .Range("m" & .Rows.Count).End(xlUp))
For Each n In .Range("n2", .Range("n" & .Rows.Count).End(xlUp))
For Each o In .Range("o2", .Range("o" & .Rows.Count).End(xlUp))
For Each p In .Range("p2", .Range("p" & .Rows.Count).End(xlUp))
For Each q In .Range("q2", .Range("q" & .Rows.Count).End(xlUp))
For Each r In .Range("r2", .Range("r" & .Rows.Count).End(xlUp))
For Each s In .Range("s2", .Range("s" & .Rows.Count).End(xlUp))
For Each t In .Range("t2", .Range("t" & .Rows.Count).End(xlUp))

combination(counter) = a.Value & "*" & b.Value & "*" & c.Value & "*" & d.Value & "*" & e.Value & "*" & f.Value & "*" & g.Value & "*" & h..Value & "*" & i.Value & "*" & j.Value & "*" & k.Value & "*" & l.Value & "*" & m.Value & "*" & n.Value & "*" & o.Value & "*" & p.Value & "*" & q.Value& "*" & r.Value & "*" & s.Value & "*" & t.Value
counter = counter + 1
Next t
Next s
Next r
Next q
Next p
Next o
Next n
Next m
Next l
Next k
Next j
Next i
Next h
Next g
Next f
Next e
Next d
Next c
Next b
Next a

End With
End Sub

Basically it combines all column words into one sentence with * as seperation... Anyway. My problem is. It doesnt want finish till end or at least as much as excel can...

Sometimes it stopes on around 65k combinations sometimes on 85k... But never till end. It gives me error.

Now I think code works "ok" but it doesnt want to finish it.

And I am not sure what is wrong.

I hope someone can help me.

P.S. Hi Claus lol
 
D

dguillett

So I have this code



Sub comb()

Dim a As Range

Dim b As Range

Dim c As Range

Dim d As Range

Dim e As Range

Dim f As Range

Dim g As Range

Dim h As Range

Dim i As Range

Dim j As Range

Dim k As Range

Dim l As Range

Dim m As Range

Dim n As Range

Dim o As Range

Dim p As Range

Dim q As Range

Dim r As Range

Dim s As Range

Dim t As Range



Dim combination As Range

Dim counter

Set combination = Worksheets(1).Range("v:v")

counter = 1

With Worksheets(1)

For Each a In .Range("A2", .Range("A" & .Rows.Count).End(xlUp))

For Each b In .Range("B2", .Range("B" & .Rows.Count).End(xlUp))

For Each c In .Range("c2", .Range("c" & .Rows.Count).End(xlUp))

For Each d In .Range("d2", .Range("d" & .Rows.Count).End(xlUp))

For Each e In .Range("e2", .Range("e" & .Rows.Count).End(xlUp))

For Each f In .Range("f2", .Range("f" & .Rows.Count).End(xlUp))

For Each g In .Range("g2", .Range("g" & .Rows.Count).End(xlUp))

For Each h In .Range("h2", .Range("h" & .Rows.Count).End(xlUp))

For Each i In .Range("i2", .Range("i" & .Rows.Count).End(xlUp))

For Each j In .Range("j2", .Range("j" & .Rows.Count).End(xlUp))

For Each k In .Range("k2", .Range("k" & .Rows.Count).End(xlUp))

For Each l In .Range("l2", .Range("l" & .Rows.Count).End(xlUp))

For Each m In .Range("m2", .Range("m" & .Rows.Count).End(xlUp))

For Each n In .Range("n2", .Range("n" & .Rows.Count).End(xlUp))

For Each o In .Range("o2", .Range("o" & .Rows.Count).End(xlUp))

For Each p In .Range("p2", .Range("p" & .Rows.Count).End(xlUp))

For Each q In .Range("q2", .Range("q" & .Rows.Count).End(xlUp))

For Each r In .Range("r2", .Range("r" & .Rows.Count).End(xlUp))

For Each s In .Range("s2", .Range("s" & .Rows.Count).End(xlUp))

For Each t In .Range("t2", .Range("t" & .Rows.Count).End(xlUp))



combination(counter) = a.Value & "*" & b.Value & "*" & c.Value & "*" & d.Value & "*" & e.Value & "*" & f.Value & "*" & g.Value & "*" &h.Value & "*" & i.Value & "*" & j.Value & "*" & k.Value & "*" & l.Value & "*" & m.Value & "*" & n.Value & "*" & o.Value & "*" & p.Value & "*" & q.Value & "*" & r.Value & "*" & s.Value & "*" & t.Value

counter = counter + 1

Next t

Next s

Next r

Next q

Next p

Next o

Next n

Next m

Next l

Next k

Next j

Next i

Next h

Next g

Next f

Next e

Next d

Next c

Next b

Next a



End With

End Sub



Basically it combines all column words into one sentence with * as seperation... Anyway. My problem is. It doesnt want finish till end or at least as much as excel can...



Sometimes it stopes on around 65k combinations sometimes on 85k... But never till end. It gives me error.



Now I think code works "ok" but it doesnt want to finish it.



And I am not sure what is wrong.



I hope someone can help me.



P.S. Hi Claus lol
Click to expand...

This should do it. I don't know where you want the sentences.

Sub makesentencesSAS()
Dim i As Long
Dim ii As Long
Dim ms As String

For i = 1 To Cells(1, Columns.Count).End(xlToLeft).Column
ms = ""
For ii = 1 To Cells(Rows.Count, i).End(xlUp).Row
ms = ms + Cells(ii, i) & "*"
Next ii
MsgBox ms
Next i
End Sub
 
B

bojan0810

Dana srijeda, 17. rujna 2014. 22:05:17 UTC+2, korisnik (e-mail address removed) napisao je:
This should do it. I don't know where you want the sentences.



Sub makesentencesSAS()

Dim i As Long

Dim ii As Long

Dim ms As String



For i = 1 To Cells(1, Columns.Count).End(xlToLeft).Column

ms = ""

For ii = 1 To Cells(Rows.Count, i).End(xlUp).Row

ms = ms + Cells(ii, i) & "*"

Next ii

MsgBox ms

Next i

End Sub
Click to expand...

Hi there. Thanks for reply...

Data is A:T columns. And I want all combination in column V. Actually it isnt matter in what column are combinations, only it cant be from A:T... Somecolumns have 2-3 words some around 10 some less etc.
 
G

GS

Perhaps...


Sub BuildStrings()
Dim vData, vRet(), n&, j&

With ActiveSheet
vData = .Range("A1:T" & .UsedRange.Rows.Count)
End With

ReDim vRet(1 To UBound(vData))
For n = LBound(vData) To UBound(vData)
vRet(n) = Join(Application.Index(vData, n, 0), "*")
Next 'n
Range("V1").Resize(UBound(vRet)) = Application.Transpose(vRet)
End Sub

--
Garry

Free usenet access at http://www.eternal-september.org
Classic VB Users Regroup!
comp.lang.basic.visual.misc
microsoft.public.vb.general.discussion
 
G

GS

You can obviate the need for transposing as follows...

Sub BuildStrings()
Dim vData, n&

With ActiveSheet
vData = .Range("A1:T" & .UsedRange.Rows.Count)
End With

ReDim vRet(1 To UBound(vData), 1 To 1)
For n = LBound(vData) To UBound(vData)
vRet(n, 1) = Join(Application.Index(vData, n, 0), "*")
Next 'n
Range("V1").Resize(UBound(vRet), 1) = vRet
End Sub

--
Garry

Free usenet access at http://www.eternal-september.org
Classic VB Users Regroup!
comp.lang.basic.visual.misc
microsoft.public.vb.general.discussion
 
C

Claus Busch

Hi Bojan,

Am Wed, 17 Sep 2014 12:35:15 -0700 (PDT) schrieb (e-mail address removed):
Basically it combines all column words into one sentence with * as seperation... Anyway. My problem is. It doesnt want finish till end or at least as much as excel can...

Sometimes it stopes on around 65k combinations sometimes on 85k... But never till end. It gives me error.
Click to expand...

try:

Sub Test()
Dim i As Long, j As Long, n As Long
Dim arrOut() As Variant
Dim myStr As String

With ActiveSheet
For i = 1 To .UsedRange.Rows.Count
For j = 1 To 20
myStr = myStr & .Cells(i, j) & " "
Next
ReDim Preserve arrOut(.UsedRange.Rows.Count - 1)
arrOut(n) = WorksheetFunction.Trim(myStr)
myStr = ""
n = n + 1
Next
.Range("V1").Resize(n, 1) = Application.Transpose(arrOut)
.Range("V1:V" & n).Replace what:=" ", Replacement:="*"
End With
End Sub


Regards
Claus B.
 
B

bojan0810

Hi all. thanks for replying

On first GS code I am getting type mismatch... Second code si combining only few. I mean it doesnt make all possible combinations.

On Claus formula I am getting same type mismatch error.

I think this is causing a problem on my first code what I wrote...

76,046,294,016,000

If I calculated right. That is number of combinations.
 
G

GS

Hi all. thanks for replying
On first GS code I am getting type mismatch... Second code si
combining only few. I mean it doesnt make all possible combinations.

On Claus formula I am getting same type mismatch error.

I think this is causing a problem on my first code what I wrote...

76,046,294,016,000

If I calculated right. That is number of combinations.
Click to expand...

Show us some sample data from the row that throws the error!

--
Garry

Free usenet access at http://www.eternal-september.org
Classic VB Users Regroup!
comp.lang.basic.visual.misc
microsoft.public.vb.general.discussion
 
G

GS

Orders of magnitude faster(1) than my original approach! Could be
simpler, though...

Sub BuildStrings2()
Dim n&, vTmp

ReDim vRet(1 To ActiveSheet.UsedRange.Rows.Count)
For n = LBound(vRet) To UBound(vRet)
vTmp = Range(Cells(n, 1), Cells(n, 20))
vRet(n) = Join(Application.Index(vTmp, 1, 0), "*")
Next
Range("V1").Resize(UBound(vRet)) = Application.Transpose(vRet)
End Sub

...without any performance loss!

(1) I haven't rebooted my machine yet this month! I suspect my original
approach is using PageFile for memory swap now!<g>

--
Garry

Free usenet access at http://www.eternal-september.org
Classic VB Users Regroup!
comp.lang.basic.visual.misc
microsoft.public.vb.general.discussion
 
C

Claus Busch

Hi Garry,

Am Thu, 18 Sep 2014 06:23:06 -0400 schrieb GS:
Orders of magnitude faster(1) than my original approach! Could be
simpler, though...
Click to expand...

the OP wrote that not all cells are filled. With your code the asterix
will be repeated if the cell has no value e.g.
****Test19**Test21*****

I first concatenate with spaces and delete the superfluous spaces with
worksheetfunction.trim and then replace the single spaces with the
asterix



Regards
Claus B.
 
G

GS

Hi Garry,
Am Thu, 18 Sep 2014 06:23:06 -0400 schrieb GS:


the OP wrote that not all cells are filled. With your code the
asterix will be repeated if the cell has no value e.g.
****Test19**Test21*****

I first concatenate with spaces and delete the superfluous spaces
with worksheetfunction.trim and then replace the single spaces with
the asterix



Regards
Claus B.
Click to expand...

Quite true! Good idea to include a remedy for blank cells...

Sub BuildStrings3()
Dim n&, vTmp

ReDim vRet(1 To ActiveSheet.UsedRange.Rows.Count)
For n = LBound(vRet) To UBound(vRet)
vTmp = Range(Cells(n, 1), Cells(n, 20))
vTmp = Join(Application.Index(vTmp, 1, 0), " ")
vRet(n) = Replace(WorksheetFunction.Trim(vTmp), " ", "*")
Next
Range("V1").Resize(UBound(vRet)) = Application.Transpose(vRet)
End Sub

--
Garry

Free usenet access at http://www.eternal-september.org
Classic VB Users Regroup!
comp.lang.basic.visual.misc
microsoft.public.vb.general.discussion
 
G

GS

This version eliminates using Transpose()...

Sub BuildStrings3a()
Dim n&, vTmp

ReDim vRet(1 To ActiveSheet.UsedRange.Rows.Count, 1 To 1)
For n = LBound(vRet) To UBound(vRet)
vTmp = Range(Cells(n, 1), Cells(n, 20))
vTmp = Join(Application.Index(vTmp, 1, 0), " ")
vRet(n, 1) = Replace(WorksheetFunction.Trim(vTmp), " ", "*")
Next
Range("V1").Resize(UBound(vRet)) = vRet
End Sub

--
Garry

Free usenet access at http://www.eternal-september.org
Classic VB Users Regroup!
comp.lang.basic.visual.misc
microsoft.public.vb.general.discussion
 
B

bojan0810

Hi again. Sorry for late reply. Pretty busy... And thats for answers.

https://www.dropbox.com/s/epq7amtzd0g5bv3/Data_Requirements_Refined_v3.xlsm?dl=0

thats the file.

I needed combinations of this words. Maybe you understanded me wrong.

There are 76,046,294,016,000 different combinations of these words. I thinkthats why my code isnt working. Code is in file...

But, actually I had different solution. Because of so many combinations, I used random words from column. And with that I can make as many as I want combinations. Because of 76,046,294,016,000 combinations, it is probably imposible to make same combination twice. Even if I use max rows in excel, it wouldnt be duplicates. Even there is chance for that but you would win lotery before that this lol...

Anyway. Is there any way to make like I did there in file what I sent, justto get desired combinations. For example, only first 100k no more. I triedto put range v1:v100000 but that doesnt work.

Thanks again for all
 
C

Claus Busch

Hi Bojan,

Am Sat, 20 Sep 2014 05:05:11 -0700 (PDT) schrieb (e-mail address removed):
Anyway. Is there any way to make like I did there in file what I sent, just to get desired combinations. For example, only first 100k no more. I tried to put range v1:v100000 but that doesnt work.
Click to expand...

for 100000+ random values try:

Sub Test2()
Dim i As Long, n As Long, z As Long, LRow As Long
Dim arrRows(19) As Variant, arrOut(119999, 0) As Variant
Dim myStr As String

With ActiveSheet
For i = 1 To 20
arrRows(n) = .Cells(Rows.Count, i).End(xlUp).Row
n = n + 1
Next
End With
z = 1
With WorksheetFunction
For n = 1 To 120000
myStr = ""
For i = LBound(arrRows) To UBound(arrRows)
myStr = myStr & Cells(.RandBetween(2, arrRows(i)), i + 1) & "*"
Next
arrOut(n - 1, 0) = Left(myStr, Len(myStr) - 1)
Next
End With

With ActiveSheet
.Range("V1").Resize(UBound(arrOut) + 1) = arrOut
.Range("$V$1:$V$120000").RemoveDuplicates Columns:=1, _
Header:=xlNo
End With
End Sub


Regards
Claus B.
 
I

isabelle

hi ,

if we Knew the final goal you want to achieve, maybe we could find a better approach

isabelle

Le 2014-09-20 08:05, (e-mail address removed) a écrit :
 
G

GS

hi ,
if we Knew the final goal you want to achieve, maybe we could find a
better approach

isabelle

Le 2014-09-20 08:05, (e-mail address removed) a écrit :
Click to expand...

Isabelle,
I'm reading it as OP wants every possible conctaenation for each cell
with all other cells in the range. I'm thinking that a main 2D array
with all data, and a tmp 2D array loaded with each column of the main
array to iterate the entire main array for each non-blank value in
both/either. So for example, the 1st col has 2 values (excluding
header) and so iterate each of these through all cols and add each
non-blank element to an output string. What's not certain is how the
output col needs to reflect the source data because there's no way it
will align by rows. Also, the number of results will span several cols
based on the number of entries allowed per col.<g>

--
Garry

Free usenet access at http://www.eternal-september.org
Classic VB Users Regroup!
comp.lang.basic.visual.misc
microsoft.public.vb.general.discussion
 
G

GS

Here's my 1st attempt at working with your file. It assumes the
following...

Data range is "A:T"; Output range is "V".
No dupes allowed in combos; No blanks allowed in combos.
Each non-blank cell in the range (114) is combined with
all other non-blank cells in the range (113).
Multi-word cells are treated as a single value.
No dupe combos allowed in output range.


Place the following code in a standard module...

Option Explicit

Sub BuildStrings4()
Dim vTmp, vaRet(), rng As Range, c As Range, vaNumRows(1 To 20)
Dim saList$(), sTmp$, sz$, n&, j&, lMaxRows&

On Error GoTo Cleanup
'Get number of rows per column
For n = 1 To 20
vNumRows(n) = Cells(1, n).End(xlDown).Row
If vNumRows(n) > lMaxRows Then lMaxRows = vNumRows(n)
Next 'n

For Each c In Range(Cells(2, "A"), Cells(lMaxRows,
"T")).SpecialCells(2)
sz = c
For n = 2 To lMaxRows
vTmp = Range(Cells(n, "A"), Cells(n, "T")) '//exclude headers
'No dupes
sTmp = Join(Application.Index(vTmp, 1, 0), "*")
saList = Split(sz & "*" & sTmp, "*")
CreateList_UniqueItems vTmp, saList: ReDim Preserve vRet(j)
'No blanks
'(**There will only be 1 blank after CreateList_UniqueItems**)
vRet(j) = Replace(Join(vTmp, "*"), "**", "*"): j = j + 1
Next 'n
Next 'c

ConvertArray_1DimTo2D vRet: lMaxRows = UBound(vRet) + 1
Set c = Range("V1").Resize(lMaxRows, 1)
c = vRet: c.RemoveDuplicates 1, xlNo

Cleanup:
Set rng = Nothing: Set c = Nothing
End Sub 'BuildStrings4

Sub ConvertArray_1DimTo2D(Arr())
' Restructures a 1D dynamic 0-based array to a fixed 2D 0-based array
' Arguments:
' Arr$() array to be converted
'
Dim vTmp, n&

If (VarType(Arr) < vbArray) Then Exit Sub

vTmp = Arr: Erase Arr: ReDim Arr(UBound(vTmp), 0)
For n = LBound(vTmp) To UBound(vTmp)
Arr(n, 0) = vTmp(n)
Next 'n
End Sub 'ConvertArray_1DimTo2D

Function CreateList_UniqueItems(ListOut, TextIn$()) As Boolean
' Filters an array for any duplicates and strips them out.
' Returning a unique list to the caller ByRef.
'
' Args In: ListOut: ByRef variant to return array of matches found
to the caller.
' TextIn(): String array cotaining the list to filter.
'
' Returns: True if matches found and no error occurs;
' False if a: matches not found --OR-- error occurs;

Dim i&, j&, bMatch As Boolean
Dim vFilterRng, vCheckRng, vResult
Dim vaMatches(), vaDataOut()

'Load the filtering criteria
vFilterRng = TextIn: vCheckRng = vFilterRng
ReDim vaMatches(UBound(vFilterRng)): j = 0

'Load a Collection with the values to be checked.
'Collections only allow unique keys so use OERN (no need to check if
they already exist)
Dim cItemsToCheck As New Collection: On Error Resume Next
For i = LBound(vCheckRng) To UBound(vCheckRng)
cItemsToCheck.Add Key:=CStr(vCheckRng(i)), Item:=vbNullString
Next 'i
Err.Clear

'Check the Collection for matches
On Error GoTo MatchFound
For i = LBound(vFilterRng) To UBound(vFilterRng)
bMatch = False '..reset
cItemsToCheck.Add Key:=CStr(vFilterRng(i)), Item:=vbNullString
If bMatch Then vaMatches(j) = vFilterRng(i): j = j + 1
Next 'i

'Initialize the return list
vResult = vaMatches

'Return a list of unique values?
On Error GoTo UniqueList
Dim cUniqueList As New Collection
For i = LBound(vResult) To UBound(vResult)
cUniqueList.Add Key:=CStr(vResult(i)), Item:=vbNullString
Next 'i
ReDim vaDataOut(cUniqueList.Count - 1)
j = 0: Err.Clear: On Error GoTo ErrExit

'Make the list to return contiguous.
ListOut = Filter(vResult, "|", False)


ErrExit:
CreateList_UniqueItems = (Err = 0): Exit Function

MatchFound:
bMatch = True: Resume Next

UniqueList:
vResult(i) = "|": Resume Next

End Function 'CreateList_UniqueItems

--
Garry

Free usenet access at http://www.eternal-september.org
Classic VB Users Regroup!
comp.lang.basic.visual.misc
microsoft.public.vb.general.discussion
 
B

bojan0810

Thanks all for helping.

I was looking something like Claus code. That did it. With that code I can change the number of desired cells for combination. As number of combination of this workbook is much much bigger then max number of rows.

Thanks again all, and thanks Claus.
 

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Similar Threads

Array macro question 4
Macro for comparing columns and highlighting matching/differences 14
Copy a range data from 1 sheet to multiple selected sheets 1
A simple if <> nn then Msgbox "No Match" 5
Open four Wbooks, copy four columns from each to Master Wbook 16
Advanced Filter Error - I cannot spot my Error 3
combining row values into one cell while filter is active 6
VBA Macro - Copying specific data to different sheets in a workbookand linking the InputBox to a com 7

Top