I'm currently in need of extracting cell values from a correlation table that fit a certain profile, e.g. "<0.6". This could an easy enough manual task if it weren't for the fact that I'm running correlation coefficients for >4,000 items. The idea for the output would be to create another table with a concatenate column showing the items involved and another column containing the value for the correlation of those items.
I'd imagine that VBA would be the way to go but maybe there's some other faster and simpler way I could be overlooking.
Any help would be much appreciated!
Thanks in advance :)
Sub extract()
Worksheets("Matrix").Select
Range("A1").Select
Dim Row As Long
Dim Col As Long
x = 1
y = 1
i = 0
Worksheets("Paste").Cells.ClearContents
Worksheets("Paste").Range("A1") = "X"
Worksheets("Paste").Range("B1") = "Y"
Worksheets("Paste").Range("C1") = "Value"
Worksheets("Matrix").Activate
Row = Worksheets("Matrix").Range("A1", Worksheets("Matrix").Range("A1").End(xlDown)).Rows.Count
Col = Worksheets("Matrix").Range("A1", Worksheets("Matrix").Range("A1").End(xlToRight)).Columns.Count
If Row <> Col Then
MsgBox "ERROR: Matrix is not symmetrical, can't be a correlation matrix"
Exit Sub
End If
For x = 1 To Row
For y = 1 To Col
If Cells(y, x) > 1 Then
Cells(y, x).Copy
Worksheets("pegar").Range("C2").Offset(RowOffset:=i).PasteSpecial xlPasteValues
Worksheets("paste").Range("B2").Offset(RowOffset:=i).Value = y
Worksheets("paste").Range("A2").Offset(RowOffset:=i).Value = x
i = i + 1
End If
Next y
Next x
Worksheets("paste").Select
MsgBox "values extracted"
End Sub
Related
I have two tables. One table is called DRData (Blad3), other table is CheckData (Blad2). EANCODE is Column J for DRData, and Column A for Checkdata.
I want to check whether CheckData.EANCODE is present in DRData.EANCODE. If so; delete that row from CheckData.
I tried several things, but no success yet. The code I have written now is as follows:
Sub FindEAN()
Dim i As Long
Dim x As Long
x = 1 'Start on first row
EANtoFind = Blad2.Range("A" & x).Value
For i = 1 To 99999 '
If Blad3.Cells(i, 1).Value = EANtoFind Then
Blad2.Range("A" & x).EntireRow.Delete
Else: x = x + 1
End If
Next i
End Sub
When the EANCODE is not present, I want to hop over a row to check that code. I want to end with a list in CheckData where all the EANCODE values that are not in DRData are shown.
With the code above, only the first row is getting deleted and now I'm stuck how to get this to loop. Including the x+1 to get to the next row.
First you have to clarify that your problem is a little bit complicated. You have to pay attention to indexes when deleting rows
To do that, you have to point the the maximal number of line to optimize your loop
A simple way to do that, is to use predefined search function, and edit your code a little bit.
My favorite is Application.match(), which takes 3 parameters :
Value to look for
Array where you look (in our case the column J of Blad3 or position 10)
0 : exact match
For more details, see the documentation
https://learn.microsoft.com/fr-fr/office/vba/api/excel.worksheetfunction.match
An example of code which works is like the following
Sub FindEAN()
Dim x As Long
x = 1 'Start on first row
maxline = Blad2.Range("A" & Rows.count).End(xlUp).row
While x <= maxline '
EANtoFind = Blad2.Range("A" & x).Value
If Not IsError(Application.Match(EANtoFind, Blad3.Columns(10), 0)) Then
Blad2.Range("A" & x).EntireRow.Delete
maxline = maxline - 1
Else
x = x + 1
End If
Wend
End Sub
Ive been trying to make something in Excel to find multiple combinations of sums.
I have list of numbers that needs to be added together to be either within ranges of 500-510 or 450-460.
Only two numbers from the list can be used to find the sum. the numbers can not be used more than once. and giving the combinations of multiple results would be great. and if a number is not used it is ok.
I've tried the solver add-in and some other tips I found from this site but could not find something that gives multiple answers.
Does anyone know if this will be possible?
I'd break this into 2 tasks. First would be to simply generate all of the index pairs to test in the input array. That's relatively simple with recursive procedure. This one uses a private Type to store the pairs, but it could adapted to use some other method of storing the pairs:
Private Type Tuple
ValueOne As Long
ValueTwo As Long
End Type
Private Sub FindCombinations(elements As Long, ByRef results() As Tuple, _
Optional ByVal iteration As Long = 0)
If iteration = 0 Then ReDim results(0)
Dim idx As Long
For idx = iteration To elements - 1
Dim combo As Tuple
With combo
.ValueOne = iteration
.ValueTwo = idx
End With
results(UBound(results)) = combo
If iteration <> elements And idx <> elements Then
ReDim Preserve results(UBound(results) + 1)
End If
Next
If iteration < elements Then FindCombinations elements, results, iteration + 1
End Sub
Then, you use a "entry-point" procedure to generate the index combinations, use those to index into your source array, and apply your selection criteria:
Private Sub FindMatchingSets(testSet() As Long)
Dim indices() As Tuple
FindCombinations UBound(testSet) + 1, indices
Dim idx As Long, results() As Tuple
For idx = LBound(indices) To UBound(indices)
Dim tupleSum As Long
tupleSum = testSet(indices(idx).ValueOne) + testSet(indices(idx).ValueTwo)
If indices(idx).ValueOne <> indices(idx).ValueTwo And _
((tupleSum >= 500 And tupleSum <= 510) Or _
(tupleSum >= 450 And tupleSum <= 460)) Then
Debug.Print testSet(indices(idx).ValueOne) & " + " & _
testSet(indices(idx).ValueTwo) & " = " & tupleSum
End If
Next
End Sub
It isn't clear what you intend to do with the results, so this simply outputs the calculated values to the Immediate Window. Example calling code:
Private Sub Example()
Dim test(4) As Long
test(0) = 100
test(1) = 200
test(2) = 250
test(3) = 260
test(4) = 400
FindMatchingSets test
End Sub
May modify it according to your need & try
Sub test()
Dim X, Y, TRw, GotNum, First, Second As Long
TRw = 1
With ThisWorkbook.ActiveSheet
For X = 1 To 100 ' assumed col A1 to A100 is the list
GotNum = .Cells(X, 1).Value
If (GotNum >= 450 And GotNum <= 460) Or (GotNum >= 500 And GotNum <= 510) Then
.Cells(X, 1).Font.Color = RGB(255, 0, 0)
First = GotNum
For Y = X + 1 To 100
GotNum = .Cells(Y, 1).Value
If (GotNum >= 450 And GotNum <= 460) Or (GotNum >= 500 And GotNum <= 510) Then
Second = GotNum
TRw = TRw + 1
.Cells(TRw, 3).Value = First ' write 1st Number in Col C
.Cells(TRw, 4).Value = Second ' write 2nd Number in Col D
.Cells(TRw, 5).Value = First + Second ' write Sum of 1st & 2nd in Col C
End If
Next Y
End If
Next X
End With
End Sub
I think your question needs to be a little clearer in terms of what your expected output is (do you want a list of combos, or just to see the results?), but here's my solution.
I've put a list of 20 numbers in column Y, and assigned them all a letter (a through to t) in column X
Then I've built a matrix of the combinations of a to t, and have entered the following formula (the below is for cell C3, but it can be copied and pasted into all parts of the matrix)
=IF(C$2=$B3,"x",VLOOKUP(C$2,$X:$Y,2,FALSE)+VLOOKUP($B3,$X:$Y,2,FALSE))
I've then used conditional formatting to set the colour of the cells if they meet your criteria for the sum - you can do this by highlighting all the sums (cell C3:V22) and going to
home / conditional formatting / new rule...
picking the rule type format only cells that contain
and then in the drop down menus picking Cell Value / Between / Your high range
and then selecting a format (fill background colour, usually)
Do this once for the "high" sum, and once for the "low" sum. You can make the colours the same or different, depending on what you want to see.
I've also for reference included a reference to what the number is in Row 1 and column A. The formula for row 1 is (example is for C1, but it can be copied across)
=VLOOKUP(C2,$X:$Y,2,FALSE)
And the formula for column A is (example for A3) =VLOOKUP(B3,$X:$Y,2,FALSE)
The advantage of this approach is that it's all in excel (no code required), but the disadvantage is that it's hard to get a list of results. You could use a different formula to just return the sum (e.g. return the text "205+298") when it meets one of the conditions, but then it's still a pain to get it out of the matrix format and into a single list. Much easier using VBA
I'm trying to make a combobox that gets its values from a range. I only want to see unique values and it must be sorted in alphabetical order (case insensitive).
Everything works fine except the sorting of data. Sorting is case sensitive but this is not what I want.
Sorting is like:
Door
Room
Window
kitchen
But the way I want it:
Door
kitchen
Room
Window
Below you can find my code:
Dim x, a, b As Long, c As Variant
Dim DataRng As String
Worksheets("House").Activate
'Unique Records
For x = 2 To Cells(Rows.Count, 4).End(xlUp).Row
If WorksheetFunction.CountIf(Range("D2:D" & x), Cells(x, 4)) = 1 Then
ComboBox1.AddItem Cells(x, 4).Value
End If
Next
'Alphabetic Order
For a = 0 To ComboBox1.ListCount - 1
For b = a To ComboBox1.ListCount - 1
If ComboBox1.List(b) < ComboBox1.List(a) Then
c = ComboBox1.List(a)
ComboBox1.List(a) = ComboBox1.List(b)
ComboBox1.List(b) = c
End If
Next
Next
End Sub
I hope someone can solve my problem or can give me a hint.
try ucase(ComboBox1.List(b))... or option compare text perhaps
I am currently trying to check cells from 2 columns (one for loop for each) and see whether they have the string true. If yes I would like to copy some cells corresponding, to another sheet(log).
I know that I have some cells, which contain the word true but when I run the program there is nothing that is copied in my other sheet.
I do not get any compiling errors and would like to know where I am wrong in this code.
Sub isLimit()
Dim a As Long, b As Long, Lr As Long
x = 2
y = 2
Lr = Worksheets("Targets").Cells(Rows.Count, "A").End(xlUp).Row
For i = 8 To Lr
If (StrComp(Cells(i, 15).Text, "TRUE")) = 0 Then
Worksheets("Log").Range("B" & x) = "no"
x = x + 1
End If
Next i
For j = 8 To Lr
If (StrComp(Cells(j, 16).Text, "TRUE")) = 0 Then
Worksheets("Log").Range("B2") = Worksheets("Targets").Range("B1").Value
Worksheets("Log").Range("C" & y) = "yes"
y = y + 1
End If
Next j
End Sub
So far, I can see two problems that might causing you the trouble.
1.Since you are not setting which sheets to be checked from line below,
It will check for the activesheet cells i,15 then return -1 or 0 (true or false).
Which will only work when your screen displays sheet where data is stored.
If (StrComp(Cells(i, 15).Text, "TRUE")) = 0 Then
2.If your DATA contains something else then TRUE (for example space before or after the value).
It might see it as something other than "TRUE"
That's all I can tell without looking at your actual data.
I need some help with some VBA. The code below sorts a bunch of data which is spread horrizonally then apends them vertically which I have posted below:
Sub Test()
Application.ScreenUpdating = False
countrow = ActiveSheet.UsedRange.Rows.Count
countcolumn = ActiveSheet.UsedRange.Columns.Count
numberofiterations = countcolumn / 6
MsgBox "Number of Rows is" & Str(countrow)
MsgBox "Number of Column is" & Str(countcolumn)
ActiveSheet.Select
a = 1
b = 1
c = 6
d = 1
While n < numberofiterations
Range(Cells(a, b), Cells(countrow, c)).Select
Selection.Copy
Sheets(2).Select
ActiveSheet.Cells(d, 1).Select
Sheets(2).Paste
Sheets(1).Select
b = b + 6
c = c + 6
d = d + countrow
n = n + 1
Wend
End Sub
It runs ok once but when running it for the second time it itteraits through to the line:
While n < numberofiterations
I can't find the reason why it drops out the loop the second time. Any help will be apriciated
Thanks,
A few things to consider:
1) Please initialize the value of n. That is, before you start your loop, set
n = 0
explicitly. If you later add other code that happens to set n to some value, you will not get the result you expect
2) When you say
countrow = ActiveSheet.UsedRange.Rows.Count
Range(Cells(a, b), Cells(countrow, c)).Select
You will not get a selection all the way to the bottom of the range IF THE USED RANGE DIDN'T START IN ROW 1. If UsedRange = $Q1:Z20, then UsedRange.Rows.Count = 10, not 26!
This second point is probably not your problem today - but I wanted to point it out as it will bite you another time.
3) I am a huge fan of writing
Option Explicit
at the top of every module. It forces you to be thoughtful about every variable you create, and more likely will make you remember to initialize variables as well. In general it's good practice, and should be right up there on your list with "initialize right before you use".