Hi my code currently looks like this
Sub Solbjerg()
Set i = Sheets("Samlet")
Set e = Sheets("ABC")
Dim d
Dim j
d = 7
j = 7
Do Until IsEmpty(i.Range("A" & j))
If i.Range("A" & j) = "Cinema ABC" Then
d = d + 1
e.Rows(d).Value = i.Rows(j).Value
End If
j = j + 1
Loop
End Sub
However sometimes the data i get is not always "Cinema ABC" but just "ABC". So i need my code to search if the data contains "ABC" instead of equals to "Cinema ABC".
Can you guys help me?
Change
If i.Range("A" & j) = "Cinema ABC" Then
to
If InStr(1, i.Range("A" & j), "ABC") Then
Sub Solbjerg()
Set i = Sheets("Samlet")
Set e = Sheets("ABC")
Dim d
Dim j
d = 7
j = 7
Do Until IsEmpty(i.Range("A" & j))
If i.Range("A" & j) like "*ABC" Then
d = d + 1
e.Rows(d).Value = i.Rows(j).Value
End If
j = j + 1
Loop
End Sub
Like, and * works as wildcards
Related
I was wondering why the following syntax does not work the way I thought it would in VBA, and what I should do to ensure it does;
For a = 1 To 10
For b = 1 To 10
For c = 1 To 10
If a <> b <> c Then
MsgBox (a & " " & b & " " & c)
End If
Next c
Next b
Next a
This is a simplified example, which can still be manually obtained with:
if a<>b and b<>c and c<>a then
But my actual intended code has 10 such variables multiple times, which makes it unfeasible with 55 unequal conditions, or likely for me to make a typo. I think there is a more efficient way but I have not found it.
Ps. My goal is to only have a message box pop up if all the variables are unique.
I have obtained my goal, though it can probably be done much more efficient than:
For a = 1 To 10
check(a) = True
For b = 1 To 10
If check(b) = False Then
check(b) = True
For c = 1 To 10
If check(c) = False Then
check(c) = True
For d = 1 To 10
If check(d) = False Then
check(d) = True
For e = 1 To 10
If check(e) = False Then
check(e) = True
MsgBox (a & " " & b & " " & c & " " & d & " " & e)
End If
check(e) = False
check(a) = True
check(b) = True
check(c) = True
check(d) = True
Next e
End If
check(d) = False
check(a) = True
check(b) = True
check(c) = True
Next d
End If
check(c) = False
check(a) = True
check(b) = True
Next c
End If
check(b) = False
check(a) = True
Next b
Next a
Here is an implementation of the Johnson-Trotter algorithm for enumerating permutations. It is a small modification of one that I wrote once when playing around with brute-force solutions to the Traveling Salesman Problem. Note that it returns a 2-dimensional array, which might consume a lot of memory. It is possible to refactor it so that it is a sub where the permutations are consumed rather than stored. Just replace the part of the code near the bottom (where the current permutation, perm, is stored in the array perms) by the code that uses the permutation.
Function Permutations(n As Long) As Variant
'implements Johnson-Trotter algorithm for
'listing permutations. Returns results as a variant array
'Thus not feasible for n > 10 or so
Dim perm As Variant, perms As Variant
Dim i As Long, j As Long, k As Long, r As Long, D As Long, m As Long
Dim p_i As Long, p_j As Long
Dim state As Variant
m = Application.WorksheetFunction.Fact(n)
ReDim perm(1 To n)
ReDim perms(1 To m, 1 To n) As Integer
ReDim state(1 To n, 1 To 2) 'state(i,1) = where item i is currently in perm
'state(i,2) = direction of i
k = 1 'will point to current permutation
For i = 1 To n
perm(i) = i
perms(k, i) = i
state(i, 1) = i
state(i, 2) = -1
Next i
state(1, 2) = 0
i = n 'from here on out, i will denote the largest moving
'will be 0 at the end
Do While i > 0
D = state(i, 2)
'swap
p_i = state(i, 1)
p_j = p_i + D
j = perm(p_j)
perm(p_i) = j
state(i, 1) = p_j
perm(p_j) = i
state(j, 1) = p_i
p_i = p_j
If p_i = 1 Or p_i = n Then
state(i, 2) = 0
Else
p_j = p_i + D
If perm(p_j) > i Then state(i, 2) = 0
End If
For j = i + 1 To n
If state(j, 1) < p_i Then
state(j, 2) = 1
Else
state(j, 2) = -1
End If
Next j
'now find i for next pass through loop
If i < n Then
i = n
Else
i = 0
For j = 1 To n
If state(j, 2) <> 0 And j > i Then i = j
Next j
End If
'record perm in perms:
k = k + 1
For r = 1 To n
perms(k, r) = perm(r)
Next r
Loop
Permutations = perms
End Function
Tested like:
Sub test()
Range("A1:G5040").Value = Permutations(7)
Dim A As Variant, i As Long, s As String
A = Permutations(10)
For i = 1 To 10
s = s & " " & A(3628800, i)
Next i
Debug.Print s
End Sub
The first 20 rows of output look like:
Also, 2 1 3 4 5 6 7 8 9 10 is printed in the immediate window. My first version used a vanilla variant away and caused an out-of-memory error with n = 10. I tweaked it so that perms is redimensioned to contain integers (which consume less memory than variants) and is now able to handle 10. It takes about 10 seconds on my machine to run the test code.
You could simply add a check right after the beginning of each inner loop, like follows
For a = 1 To 10
For b = 1 To 10
If b <> a Then '<-- this check will make sure subsequent inner loops shouldn't bother but for their loops variables
For c = 1 To 10
If c <> b Then '<-- same comment as preceeding one
For d = 1 to 10
If d <> c then MsgBox (a & " " & b & " " & c & " " & d) '<-- last check for last two variables
Next d
End If
Next c
End If
Next b
Next a
Try putting all those variables into the array and checking the array for duplicates, if none found, display the message box. Something like this:
Sub dupfind()
Dim ArrHelper(2) As Long
Dim k As Long
Dim j As Long
Dim ans As Long
Dim dupl As Boolean
Dim ArrAnswers() As Long
ans = 0
For a = 1 To 10
ArrHelper(0) = a
For b = 2 To 10
ArrHelper(1) = b
For c = 1 To 10
ArrHelper(2) = c
dupl = False
For k = 0 To UBound(ArrHelper) - 1
For j = k + 1 To UBound(ArrHelper)
If ArrHelper(k) = ArrHelper(j) Then
dupl = True
End If
Next j
Next k
If dupl = False Then
ReDim Preserve ArrAnswers(3, ans)
ArrAnswers(0, ans) = a
ArrAnswers(1, ans) = b
ArrAnswers(2, ans) = c
ans = ans + 1
End If
Next c
Next b
Next a
End Sub
Read your edit regarding storing permutations and changed the code a bit
I'm trying to copy values from one small sheet "MD with ID" to A Larger sheet "D with ID" if 2 fields are identical (consider those two as keys that identify each record).
Here is my first try:
Sub CopyIDCells()
Set i = Sheets("MD with ID")
Set e = Sheets("D with ID")
Dim d
Dim j
d = 1
j = 2
Do Until IsEmpty(e.Range("B" & j))
d = 2
Do Until IsEmpty(i.Range("A" & d))
If e.Range("C" & j).Value = i.Range("D" & d).Value Then
If e.Range("M" & j).Value = i.Range("J" & d).Value Then
e.Range("A" & j).Value = i.Range("B" & d).Value
End If
End If
d = d + 1
Loop
j = j + 1
Loop
End Sub
Here is my second try:
Sub CopyIDCells2()
Set i = Sheets("MD with ID")
Set e = Sheets("D with ID")
Dim d
Dim j
d = 1
j = 2
Do Until j = 20886
d = 2
Do Until d = 1742
If e.Cells(j, 3).Value = i.Cells(d, 4).Value Then
If e.Cells(j, 13).Value = i.Cells(d, 10).Value Then
e.Cells(j, 1).Value = i.Cells(d, 2).Value
End If
End If
d = d + 1
Loop
j = j + 1
Loop
End Sub
Nothing changes in the excel sheet when this code runs, although it takes few minutes to run -_-".
.. sample was removed
So looking at your first CopyIdCells method, there is only one fix I would make to this - make variable d=2. This has headers at the top of your sample data and you need to start on row 2 just like the other sheet.
Sub CopyIDCells()
Set i = Sheets("MD with ID")
Set e = Sheets("D with ID")
Dim d
Dim j
d = 2
j = 2
Do Until IsEmpty(e.Range("B" & j))
d = 2
Do Until IsEmpty(i.Range("A" & d))
If e.Range("C" & j).Value = i.Range("D" & d).Value Then
If e.Range("M" & j).Value = i.Range("J" & d).Value Then
e.Range("A" & j).Value = i.Range("B" & d).Value
End If
End If
d = d + 1
Loop
j = j + 1
Loop
End Sub
Other than that your formulas look good, you just do not have any data that meets your requirements. Add this column to the bottom of "MD with ID" and you will see your code match.
mouse 10 08 11267 A/J M 823 1/11/2008 1 SC-807 LONG 10/10/2005
Since you are matching on "Case Number" AND "Other ID" there are no items in both sheets that meet this criteria. When you add the row above to "MD with ID", you will see the appropriate ID added to your second sheet on several rows.
I'm trying VLookup until the cells in Column A are empty and it is not working and is returning Run-time error '1004' Unable to get the VLookup property of the WorksheetFunction class. Any help? Or is there a better loop that I can use.
Sub FindOldValue()
Dim oldvalue As String
Dim result As String
i = 2
j = 1
K = 2
l = 3
Do
oldvalue = Worksheets("Products").Cells(i, j) & Worksheets("Products").Cells(i, K) & "delete"
result = Application.WorksheetFunction.VLookup(oldvalue, Worksheets("Raw Delta").Range("A:H"), 7, 0)
Worksheets("Products").Cells(i, l) = result
i = i + 1
j = j + 1
K = K + 1
Loop Until Worksheets("Products").Cells(i, 1) = ""
End Sub
Have you tried using only Application.Vlookup instead of Application.Worksheetfunction.vlookup in the line
result = Application.WorksheetFunction.VLookup(oldvalue, Worksheets("Raw Delta").Range("A:H"), 7, 0)
?
How about changing the loop to something like this?
Do
oldvalue = Worksheets("Products").Cells(i, j) & Worksheets("Products").Cells(i, K) & "delete"
resultrow = Application.Match(oldvalue, Worksheets("Raw Delta").Columns(1), 0)
If Not IsError(resultrow) Then
Worksheets("Products").Cells(i, l) = Worksheets("Raw Delta").Cells(resultrow,7).Value
End If
i = i + 1
j = j + 1
K = K + 1
Loop Until Worksheets("Products").Cells(i, 1) = ""
I am trying to find a code that would help me move an entire row to another sheet if it contains the word "Processing" the original sheet is called "Output 1" and the sheet where i need to move it to is "Applications" this is the code i found online but its giving me errors-Thanks ( i am not sure what d and j mean since i got it online)
Set i = Sheets("Output 1")
Set e = Sheets("Applications")
Dim d
Dim j
d = 1
j = 2
Do Until IsEmpty(i.Range("B" & j))
If i.Range("B" & j) = "Processing" Then
d = d + 1
e.Rows(d).Value = i.Rows(j).Value
End If
j = j + 1
Loop
Does this work?
Sub DoIt()
Dim i As Worksheet, e As Worksheet
Dim d, j
Set i = Sheets("Output 1")
Set e = Sheets("Applications")
d = 1
j = 2
Do Until IsEmpty(i.Range("B" & j))
If i.Range("B" & j) = "Processing" Then
d = d + 1
e.Rows(d).Value = i.Rows(j).Value
End If
j = j + 1
Loop
End Sub
I'm in the situation described by fig.1 where I have a cell with the reference name and a cell with one or more semicolon separated emails associated to the same reference. I'd like to split the cells contaning more than one email stacking them consecutively and copying the refence name. Is it possible to do this with a VBA Macro in Excel 2007? I know the existence of the "Split in columns" command, but I don't know how to automatically shift the columns in rows and copying the reference name. Thanks in advance.
Here you go:
Sub SplitColumnB()
Dim r As Range
Set r = [B2]
Do While r.Value <> ""
res = Split(r.Value, " ; ")
i = 0
For Each resStr In res
If i > 0 Then r.Offset(1).EntireRow.Insert xlDown
r.Offset(IIf(i > 0, 1, 0)).Value = resStr
r.Offset(IIf(i > 0, 1, 0), -1).Value = Right(resStr, Len(resStr) - InStr(resStr, "#"))
i = i + 1
Next
Set r = r.Offset(IIf(i > 0, i, 1))
Loop
End Sub
Try with the below code. Replace all instances of Sheet1 with the name of your worksheet.
Sub test()
Dim Ref As String
Dim Eid As String
Dim RefR()
Dim EidR()
Rcnt = Sheets("Sheet1").Range("A65000").End(xlUp).Row
K = 0
L = 0
For i = 2 To Rcnt
Ref = Sheets("Sheet1").Range("A" & i).Value
Temp = Split(Sheets("Sheet1").Range("B" & i).Value, ";")
K = K + 1
ReDim Preserve RefR(1 To K)
RefR(K) = Ref
For j = LBound(Temp) To UBound(Temp)
If L <= UBound(Temp) Then
ReDim Preserve EidR(Rcnt, L)
L = UBound(Temp)
End If
EidR(K, j) = Temp(j)
Next j
Next i
RowValue = 2
For i = 1 To UBound(RefR)
For j = 0 To L
Sheets("Sheet1").Range("A" & RowValue).Value = RefR(i)
Sheets("Sheet1").Range("B" & RowValue).Value = Trim(EidR(i, j))
RowValue = RowValue + 1
Next j
Next i
End Sub