I'm trying to simplify my code to dynamically check some values and update a bunch of tickboxes.
The tickboxes are sort of a table, their name is "col" & number_of_column & type_of_data
ie:
Col1PAM Col2PAM Col3PAM
Col1RL Col2RL Col3RL
I tried a simple approach with for...next which works:`
For i = 1 To 16
If ThisWorkbook.Sheets("Setup").Cells(j + 2, i + 1) = 1 Then
Me.Controls("Col" & i & "PAM").Value = True
Else: Me.Controls("Col" & i & "PAM").Value = False
End If
If ThisWorkbook.Sheets("Setup").Cells(j + 3, i + 1) = 1 Then
Me.Controls("Col" & i & "RL").Value = True
Else: Me.Controls("Col" & i & "RL").Value = False
End If
Next i
But I have a lot of column types and I tried to make the column type dynamic:
Dim Coltype1 As String
Dim coltype2 As String
Coltype1 = "PAM"
coltype2 = "RL"
For j = 1 To 2
For i = 1 To 16
If ThisWorkbook.Sheets("Setup").Cells(j + 2, i + 1) = 1 Then
Me.Controls("Col" & i & ("Coltype" & j)).Value = True
Else: Me.Controls("Col" & i & ("Coltype" & j)).Value = False
End If
Next i
Next j
My syntax is incorrect and after many tries, I can't figure out what would be a proper one. Any advice ?
On a side note, I also tried the for...next approach to declare my coltype1, coltype2... variables but it looks like you can't do that?
Thanks for any tips!
Something like this:
Dim arr(1 To 2) As String, ws As WorkSheet, i As Long, j As Long
Set ws = ThisWorkbook.Sheets("Setup")
arr(1) = "PAM"
arr(2) = "RL"
For j = 1 To 2
For i = 1 To 16
Me.Controls("Col" & i & arr(j)).Value = (ws.Cells(j + 2, i + 1) = 1)
Next i
Next j
Related
i have problem with my code in vba. I have to find how much similar numbers are in column 1 and 2, but for example Column 1 (6,6,34,21,23,40) and column2 (49,34,6,9,6,20) should write 3 cause there are pairs 6-6, 6-6 and 34-34. I know its messy explenation but i hope its understandable. My code so far is:
Sub totolotek()
Dim i As Integer
Dim x As Integer
Dim j As Integer
Dim liczba As Integer
Dim suma As Integer
Dim ileLosowan As Integer
Range("B2:C7").Interior.Color = RGB(135, 134, 125)
Range("B2:B7").Font.ColorIndex = 3
Range("C2:C7").Font.ColorIndex = 5
ileLosowan = 7
Randomize
For i = 2 To ileLosowan
x = Int(Rnd * (49) + 1)
Range("c" & i) = x
Next i
For i = 2 To 7
liczba = Range("c" & i)
For j = 2 To 7
liczbe = Range("b" & j)
If liczbe = liczba Then
Range("c" & i).Interior.Color = RGB(255, 255, 0)
Range("b" & j).Interior.Color = RGB(255, 255, 0)
suma = suma + 1
End If
Next j
Next i
Range("c" & 9) = suma
End Sub
Try this. I invested some time and I added some lines of code. The macro find all the number pairs.
Example (6,6,3,4,2) (2,3,6,9,0) --> results 3: (6-6, 3-3, 2-2)
Sub totolotek()
Dim i As Integer
Dim x As Integer
Dim j As Integer
Dim liczba As Integer
Dim suma As Integer
Dim ileLosowan As Integer
Dim str_B As String, str_C As String, str_BC As String
Dim max_rand As Long
ileLosowan = 20 ' you can change the number of element in the column
max_rand = 49 ' max randum number
start_row = 2 'start_row
str_BC = "B2:C" & ileLosowan
str_B = "B2:B" & ileLosowan
str_C = "C2:C" & ileLosowan
Range(str_BC).Interior.Color = RGB(135, 134, 125)
Range(str_B).Font.ColorIndex = 5
Range(str_C).Font.ColorIndex = 5
Randomize
For i = start_row To ileLosowan
x = Int(Rnd * (max_rand) + 1)
Range("C" & i) = x
Next i
For i = start_row To ileLosowan
x = Int(Rnd * (max_rand) + 1)
Range("B" & i) = x
Next i
liczba_array = Range("B" & start_row & ":B" & ileLosowan).Value2
liczbe_array = Range("C" & start_row & ":C" & ileLosowan).Value2
ReDim ID_array(1 To 1)
ID_array(1) = max_rand + 1
Count = 1
For i = 1 To UBound(liczba_array, 1)
For j = 1 To UBound(liczbe_array, 1)
For k = 1 To UBound(ID_array, 1)
If ID_array(k) = j Then
GoTo out
End If
Next k
If liczba_array(i, 1) = liczbe_array(j, 1) Then
Range("B" & (start_row + i - 1)).Interior.Color = RGB(150 + Count * 20, 0, 0)
Range("C" & (start_row + j - 1)).Interior.Color = RGB(150 + Count * 20, 0, 0)
suma = suma + 1
ID_array(Count) = j
Count = Count + 1
ReDim Preserve ID_array(1 To Count)
Exit For
End If
Next j
out:
Next i
Range("C" & ileLosowan + 2) = suma
End Sub
Something like this will do what you're after. Just incorporate it into you're code cause I don't really know what's going on there.
Dim i As Long, j As Long, arr As Variant, Total As Integer
For i = 2 To 7 'Rows to loop through in the column
Total = 0
arr = Split(Range("A" & i), ",") 'Split column A using the comma
For j = 0 To UBound(arr) 'Loop through the split values
If InStr(Range("B" & i), arr(j)) > 0 Then 'Find if value is within other column
Total = Total + 1 'If it is, add 1 to total
End If
Next j
Range("C" & i) = Total 'Write total to another column on same row
Next i
Or if you want a basic function for it that you can use in your sheet you can use this:
Public Function CountMatches(Cell As String, Rng As Range, Optional Delim As String)
Dim i As Long, j As Long, arr As Variant, Total As Integer
If Delim = "" Then Delim = ","
If Rng.Count > 1 Then
CountMatches = "Please choose 1 cell to compare to."
Exit Function
End If
Total = 0
arr = Split(Cell, Delim) 'Split column A using the comma
For j = 0 To UBound(arr) 'Loop through the split values
If InStr(Rng, arr(j)) > 0 Then 'Find if value is within other column
Total = Total + 1 'If it is, add 1 to total
End If
Next j
CountMatches = Total
End Function
Use it like =CountMatches(A1,B1,",")
I try to find a vba solution for the following problem:
I have two columns and try to group column1 in a comma separate way to have less rows.
e.g.
example:
I tried this, and it worked - but It take too long (about 300.000 Rows). Is there any better solution that task?
*Its just one part of my macro
For Each r In fr
If st = "" Then
st = Application.WorksheetFunction.Clean(Trim(ws.Cells(r.row, "L").Value))
Else
If Not IsInArray(Split(st, ","), ws.Cells(r.row, "L").Value) Then
st = st & ", " & Application.WorksheetFunction.Clean(Trim(ws.Cells(r.row, "L").Value))
End If
End If
If usrCheck = True Then
If str = "" Then
str = Application.WorksheetFunction.Clean(Trim(ws.Cells(r.row, "A").Value))
Else
If Not IsInArray(Split(str, ","), ws.Cells(r.row, "A").Value) Then
str = str & ", " & Application.WorksheetFunction.Clean(Trim(ws.Cells(r.row, "A").Value))
End If
End If
End If
Next
Maybe using Dictionary would be fast. What about:
Sub Test()
Dim x As Long, lr As Long, arr As Variant
Dim dict1 As Object: Set dict1 = CreateObject("Scripting.Dictionary")
Dim dict2 As Object: Set dict2 = CreateObject("Scripting.Dictionary")
With Sheet1 'Change accordingly
'Return your last row from column A
lr = .Cells(.Rows.Count, 1).End(xlUp).Row
'Get array and loop through it
arr = .Range("A2:B" & lr).Value
For x = LBound(arr) To UBound(arr)
dict1(arr(x, 2)) = arr(x, 2)
Next
'Loop through dictionary filling a second one
For Each Key In dict1.keys
For x = LBound(arr) To UBound(arr)
If arr(x, 2) = Key Then dict2(arr(x, 1)) = arr(x, 1)
Next x
.Range("F" & .Cells(.Rows.Count, 6).End(xlUp).Row + 1) = Key
.Range("G" & .Cells(.Rows.Count, 7).End(xlUp).Row + 1) = Join(dict2.Items, ", ")
dict2.RemoveAll
Next
End With
End Sub
This will get you all unique items from column A though, so if there can be duplicates and you want to keep them, this is not for you =)
Try also this, please. It works only in memory and on my computer takes less then 3 seconds for 300000 rows. The range must be filtered, like in your picture. If not, the filtering can also be easily automated.
Private Sub CondensData()
Dim sh As Worksheet, arrInit As Variant, arrIn As Variant, i As Long
Dim arrFinal() As Variant, lastRow As Long, Nr As Long, El As Variant
Dim strTemp As String, k As Long
Set sh = ActiveSheet
lastRow = sh.Cells(sh.Rows.count, "A").End(xlUp).Row
arrIn = sh.Range("B2:B" & lastRow + 1).Value
'Determine the number of the same accurrences:
For Each El In arrIn
i = i + 1
If i >= 2 Then
If arrIn(i, 1) <> arrIn(i - 1, 1) Then Nr = Nr + 1
End If
Next
ReDim arrFinal(Nr, 1)
arrInit = sh.Range("A2:B" & lastRow).Value
For i = 2 To UBound(arrInit, 1)
If i = 1 Then
strTemp = arrInit(1, 1)
Else
If arrInit(i, 2) = arrInit(i - 1, 2) Then
If strTemp = "" Then
strTemp = arrInit(i, 1)
Else
strTemp = strTemp & ", " & arrInit(i, 1)
End If
Else
arrFinal(k, 0) = arrInit(i - 1, 2)
arrFinal(k, 1) = strTemp
k = k + 1: strTemp = ""
End If
End If
Next i
sh.Range("C2:D" & lastRow).Clear
sh.Range("C2:D" & k - 1).Value = arrFinal
sh.Range("C:D").EntireColumn.AutoFit
MsgBox "Solved..."
End Sub
It will return the result in columns C:D
I tried several ways, but I still have a problem in my code.
What I want to do (this example in Q2 on Sheet4):
=INDEX('Sheet8'!K:K,MATCH('Sheet4'!P2,'Sheet8'!A:A,0))
I'd like to do it for all rows with content in column K on Sheet 4 so I'll probably need "For i = 1..."
What I tried:
For i = 1 To LastRowShort
row_mtch = Application.WorksheetFunction.Match(Sheet4.Cells("Q????").Value, Sheet8.Range("A1:A"), 0)
Sheet4.Range("R" & i).Value = Application.WorksheetFunction.Index(Sheet8.Range("K1:K" & LastRowShort), row_mtch)
Next i
Thanks a lot!
Andy
Entire Module:
Sub MissingBoth()
Application.ScreenUpdating = False
Dim MyRange, CopyRange As Range
Dim LastRow As Long
Dim LastRowSheet4 As Long
Dim LastRowSheet8 As Long
Set src4 = Sheet2
Set dst4 = Sheet4
LastRow = src4.Cells(Cells.Rows.Count, "D").End(xlUp).Row
LastRowSheet8 = Worksheets("Sheet8").Cells(Cells.Rows.Count, "B").End(xlUp).Row
LastRowSheet4 = Worksheets("Sheet4").Cells(Cells.Rows.Count, "K").End(xlUp).Row
src4.Unprotect
dst4.Unprotect
If src4.FilterMode = True Then
src4.ShowAllData
End If
dst4.Cells.ClearFormats
dst4.Cells.Clear
'Find content in the "Type of Rack" cells
j = 3
For i = 10 To LastRow
If src4.Cells(i, "CL").Value = "" And src4.Cells(i, "GV").Value = "" Then
src4.Cells(i, "CL").EntireRow.Copy dst4.Cells(j, 1)
j = j + 1
End If
Next i
src4.Range("A6:GW7").Copy Destination:=dst4.Range("A1:GW2")
'Copy every column EXCEPT the following
dst4.Range("GW1,CM1:GU1, U1:CK1,R1:S1,P1,J1:M1").EntireColumn.Delete
For i = 1 To LastRowSheet4
For i2 = 1 To LastRowSheet8
If Worksheets("Sheet4").Range("P" & i).Value = Worksheets("Sheet8").Range("A" & i2).Value Then
Worksheets("Sheet4").Range("Q" & i).Value = Worksheets("Sheet8").Range("K" & i2).Value
End If
Next i2
Next i
dst4.Columns("A:AX").EntireColumn.AutoFit
dst4.Rows("1:500").RowHeight = 15
dst4.Columns("N:O").Interior.Color = vbYellow
dst4.Rows("1:2").Interior.ColorIndex = 15
dst4.Range("B:I").EntireColumn.Hidden = True
Application.ScreenUpdating = True
End Sub
Have you tried something like the following code:
For i = 1 To LastRowSheet4
For i2 = 1 To LastRowSheet8
If Worksheets("Sheet4").Range("P" & i).Value = Worksheets("Sheet8").Range("A" & i2).Value Then
Worksheets("Sheet4").Range("Q" & i).Value = Worksheets("Sheet8").Range("K" & i2).Value
End If
Next i2
Next i
You will just need to define the upper ends of both sheets (LastRowSheet4 and LastRowSheet8) and this should work.
Thanks for your help. I solved the problem with recording a macro and modifying it:
Sheet4.Cells(3, 17).FormulaR1C1 = _
"=INDEX('TS-48 Matrix'!C[-7],MATCH('Missing Both'!RC[-1],'TS-48 Matrix'!C[-16],0))"
Range("Q3").AutoFill Destination:=Range("Q3:Q" & lastRowSheet4)
I'm trying to compared 2 different excel files that contain same fields sometimes.
When I find it (by watch view) the vba say they are different...
Dim ctrl As Integer
Sub btnCheck_Click()
Dim lot As Workbook, pr As Workbook, this As Workbook
Dim a As Variant, b As Variant
Dim i As Integer, j As Integer
Dim passed As Boolean
Set this = Application.ThisWorkbook
this.Worksheets(1).Range("C5:J1000").ClearContents
Application.ScreenUpdating = False
a = ThisWorkbook.Path & "\" & "A.xlsx"
Set lot = Application.Workbooks.Open(a, False, False)
b = ThisWorkbook.Path & "\" & "B.xls"
Set pr = Application.Workbooks.Open(b, False, False)
i = 2
x = 2
lin = 2
Do Until lot.Worksheets(1).Range("A" & i).Value = ""
passed = False
j = 2
Do Until pr.Worksheets(1).Range("A" & j).Value = ""
If lot.Worksheets(1).Range("B" & i).Value = pr.Worksheets(1).Range("C" & j).Value Then
passed = True
this.Worksheets(1).Range("D" & x).Value = "ok"
x = x + 2
End If
j = j + 1
Loop
i = i + 1
Loop
lot.Close True
Set lot = Nothing
pr.Close True
Set pr = Nothing
Application.ScreenUpdating = True
End Sub
Function CleanStr(ByVal str As String)
CleanStr = Replace(str, Chr$(32), "")
End Function
The files A and B are linked at the comments bellow.
A and B are not the same. One ends in a space (ASCII 32) while the other ends in a non-breaking space (ASCII 160). Invisible is invisible to our eyes, but to a computer, ASCII(32)<>ASCII(160)
You can verify this by adding this function to your macro:
Function strings2ascii(ByVal str1 As String, str2 As String)
Dim x As Integer
Dim intStrLen As Integer
Dim strResult As String
If Len(str1) > Len(str2) Then
intStrLen = Len(str1)
Else
intStrLen = Len(str2)
End If
For x = 1 To Len(str1)
strResult = strResult & Asc(Mid(str1, x, 1)) & ":" & Asc(Mid(str2, x, 1)) & vbCrLf
Next
MsgBox strResult
End Function
Now call this function in your loop:
Do Until pr.Worksheets(1).Range("A" & j).Value = ""
strings2ascii lot.Worksheets(1).Range("B" & i).Value, pr.Worksheets(1).Range("C" & j).Value
If lot.Worksheets(1).Range("B" & i).Value = pr.Worksheets(1).Range("C" & j).Value Then
You will immediately see that they never match because they are not the same. Here is a similar SO post regarding ASCII 160 errors: Trouble replacing Chr(160) with VBA in excel
Not sure if this will answer the question but that can't stand in a comment :)
I would say that some cells contains invisible chars that arent spaces.
Here's a recursive function that remove them from a string :
Function CleanString(StrIn As String) As String
' "Cleans" a string by removing embedded control (non-printable)
' characters, including carriage returns and linefeeds.
' Does not remove special characters like symbols, international
' characters, etc. This function runs recursively, each call
' removing one embedded character
Dim iCh As Integer
CleanString = StrIn
For iCh = 1 To Len(StrIn)
If Asc(Mid(StrIn, iCh, 1)) < 32 Then
'remove special character
CleanString = Left(StrIn, iCh - 1) & CleanString(Mid(StrIn, iCh + 1))
Exit Function
End If
Next iCh
End Function
Give it a try like this :
Do Until b.Worksheets(1).Range("A" & j).Value = ""
sa = CleanString(a.Worksheets(1).Range("B" & i).Value)
sb = CleanString(b.Worksheets(1).Range("C" & j).Value)
oa = CleanString(a.Worksheets(1).Range("E" & i).Value)
ob = CleanString(b.Worksheets(1).Range("F" & j).Value)
If StrComp(sa, sb) = 0 And StrComp(oa, ob) = 0 Then
Passed = True
I am trying to write a macro in Excel which will allow me to automatically do groupings based on the number located in the first column. Here is the code.
Sub Makro1()
Dim maxRow As Integer
Dim row As Integer
Dim groupRow As Integer
Dim depth As Integer
Dim currentDepth As Integer
maxRow = Range("A65536").End(xlUp).row
For row = 1 To maxRow
depth = Cells(row, 1).Value
groupRow = row + 1
currentDepth = Cells(groupRow, 1).Value
If depth >= currentDepth Then
GoTo EndForLoop
End If
Do While currentDepth > depth And groupRow <= maxRow
groupRow = groupRow + 1
currentDepth = Cells(groupRow, 1).Value
Loop
Rows(row + 1 & ":" & groupRow - 1).Select
Selection.Rows.Group
EndForLoop:
Next row
End Sub
The first column in the Excel file looks like this:
1
2
2
3
3
4
4
4
4
5
5
5
6
6
6
6
5
6
6
6
7
8
8
9
10
9
10
10
8
7
7
8
6
5
4
3
2
1
2
When the macro reaches the depth 8 speaking of the groupings, I get error number 1004. It looks like the Excel does not allow me to create a depth greater than 8. Is there a workaround for this? I am using MS Excel 2003.
You are out of luck.
There is an 8 level limit for grouping which
also exists in xl07
on my testing exists in xl2010 (gives "Group method of range class failed")
I wrote this code to hide the sublevel rows, like grouping does.
it needs the first row empty, where the general level buttons will be placed.
it will create a button (placed in the first column) for each node with sublevels.
Clicking on the buttons will hide/unhide the corresponding sublevels.
the check_col is a colum that must be filled up to the last rows (i.e. no blank rows, or the "while" loop will stop
the lvl_col is the column that contains the level index
the start_row is the first row that contains useful data
hope this helps
Sub group_tree()
check_col = "A"
lvl_col = "D"
start_row = 3
Dim btn As Button
Application.ScreenUpdating = False
ActiveSheet.Buttons.Delete
Dim t As Range
'------------Place the buttons on top--------------
i = start_row
e_lvl = 0
b_spac = 0
b_width = 20
b_toggle = 0
While Range(check_col & i) <> ""
lvl = Range(lvl_col & i)
If lvl > e_lvl Then e_lvl = lvl
i = i + 1
Wend
Set t = ActiveSheet.Range("A" & 1)
For c = Range(lvl_col & start_row) To e_lvl
Set btn = ActiveSheet.Buttons.Add(t.Left + b_spac, t.Top, b_width, 10)
With btn
.OnAction = "btnS_t"
.Caption = c
.Name = start_row & "_" & c & "_" & lvl_col & "_" & b_toggle
End With
b_spac = b_spac + 20
Next
'--------------Place the buttons at level---------
i = start_row
While Range(check_col & i) <> ""
lvl = Range(lvl_col & i)
If Range(lvl_col & i + 1) > lvl Then
Set t = ActiveSheet.Range("A" & i)
' Set btn = ActiveSheet.Buttons.Add(t.Left, t.Top, t.Width, t.Height)
Set btn = ActiveSheet.Buttons.Add(t.Left, t.Top, b_width, 10)
With btn
.OnAction = "btnS"
.Caption = lvl
.Name = i & "_" & lvl & "_" & lvl_col
End With
End If
i = i + 1
Wend
Application.ScreenUpdating = True
End Sub
Sub btnS()
Dim but_r As Integer
Set b = ActiveSheet.Buttons(Application.Caller)
id_string = b.Name
Dim id() As String
id = Split(id_string, "_")
start_row = CInt(id(0))
start_lvl = CInt(id(1))
lvl_col = id(2)
' MsgBox (lvl_col)
Call hide_rows(start_lvl, start_row, lvl_col)
End Sub
Sub hide_rows(start_lvl, start_row, lvl_col)
a = start_row + 1
While Range(lvl_col & a) > start_lvl
a = a + 1
Wend
If Range(lvl_col & start_row + 1, lvl_col & a - 1).EntireRow.Hidden = False Then
Range(lvl_col & start_row + 1, lvl_col & a - 1).EntireRow.Hidden = True
Else
Range(lvl_col & start_row + 1, lvl_col & a - 1).EntireRow.Hidden = False
End If
End Sub
Sub btnS_t()
Dim but_r As Integer
Set b = ActiveSheet.Buttons(Application.Caller)
id_string = b.Name
Dim id() As String
id = Split(id_string, "_")
start_row = CInt(id(0))
start_lvl = CInt(id(1))
lvl_col = id(2)
b_toggle = CInt(id(3))
If b_toggle = 0 Then
b_toggle = 1
Else
b_toggle = 0
End If
b.Name = start_row & "_" & start_lvl & "_" & lvl_col & "_" & b_toggle
Call hide_rows_tot(start_lvl, start_row, lvl_col, b_toggle)
End Sub
Sub hide_rows_tot(start_lvl, start_row, lvl_col, b_toggle)
a = start_row
While Range(lvl_col & a) <> ""
b = a
While Range(lvl_col & b) > start_lvl
b = b + 1
Wend
If b > a Then
If b_toggle = 1 Then
Range(lvl_col & a, lvl_col & b - 1).EntireRow.Hidden = True
Else
Range(lvl_col & a, lvl_col & b - 1).EntireRow.Hidden = False
End If
a = b - 1
End If
a = a + 1
Wend
End Sub