I am trying to convert String of cells position into range
Dim closeAfcc As Integer
Dim restCases As Integer
Dim AFCCRange As String
Dim rng As Range
i = 2
closeAfcc = 0
restCases = 0
Do
If Sheet1.Cells(i, 6) = "Closed-AFCC" Then
closeAfcc = closeAfcc + 1
AFCCRange = AFCCRange + "sheet1!K" & i & ","
Else
restCases = restCases + 1
End If
i = i + 1
Loop Until Sheet1.Cells(i, 6) = ""
AFCCRange = Left(AFCCRange, Len(AFCCRange) - 1)
Set rng = Range(AFCCRange)
I got Error 1004
my string result is
AFCCRange= sheet1!K2,sheet1!K3,sheet1!K4,sheet1!K6,sheet1!K7,sheet1!K8,sheet1!K9,sheet1!K10,sheet1!K11,sheet1!K12
Thanks
Change this code:
AFCCRange = AFCCRange + "sheet1!K" & i & ","
To read:
AFCCRange = AFCCRange & "'sheet1'!$K$" & i & ", "
Also change:
AFCCRange = Left(AFCCRange, Len(AFCCRange) - 1)
To read:
AFCCRange = Left(AFCCRange, Len(AFCCRange) - 2)
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,",")
So I have this code that sets object properties of a class in a for loop, saving each object as an element in an array, BREobjects(). The very next code is below and the first BREobjects(i).BREdays is throwing an
Object variable not set error.
It's a Public array so it shouldn't need to be redim'ed or anything. Anyone know what's happening?
Code that sets the object properties:
'creates a new object for each BRE day/time combination
count = 0
For Each i In BREitems
BREdaysString = Split(Cells(i.Row, "c").value, ", ")
For j = LBound(BREdaysString) To UBound(BREdaysString)
count = count + 1
ReDim Preserve BREobjects(count)
Set BREobjects(count) = New BREpptObjects
BREobjects(count).BREname = Cells(i.Row, "a").value
BREobjects(count).BREcategory = Cells(i.Row, "b").value
BREobjects(count).BREstartTime = Cells(i.Row, "d").value
BREobjects(count).BRElength = Cells(i.Row, "e").value
BREobjects(count).BREtimeRight = Right(Cells(i.Row, "d").value, 2)
BREobjects(count).BREdays = BREdaysString(j)
'Sets the start row number accounting for BREs that start on the half hour
If BREobjects(count).BREtimeRight = 0 Then
BREobjects(count).BREstartRow = (Cells(i.Row, "d").value / 100) + 3
BREobjects(count).BREremainder = 0
ElseIf BREobjects(count).BREtimeRight <> 0 Then
BREobjects(count).BREstartRow = ((Cells(i.Row, "d").value - BREobjects(count).BREtimeRight) / 100) + 3
BREobjects(count).BREremainder = 1
End If
'determines the row the BRE ends in
If BREobjects(count).BRElength - Fix(BREobjects(count).BRElength) = 0 Then
BREobjects(count).BREendRow = BREobjects(count).BREstartRow + BREobjects(count).BRElength - 1
ElseIf BREobjects(count).BRElength - Fix(BREobjects(count).BRElength) > 0 Or BREobjects(count).BREremainder = 1 Then
BREobjects(count).BREendRow = BREobjects(count).BREstartRow + Fix(BREobjects(count).BRElength)
End If
If BREobjects(count).BREremainder = 1 And BREobjects(count).BRElength >= 1 Then
BREobjects(count).BREendRow = BREobjects(count).BREendRow + 1
End If
'sets the end time
If BREobjects(count).BRElength - Fix(BREobjects(count).BRElength) = 0 Then
BREobjects(count).BREendTime = BREobjects(count).BREstartTime + (100 * BREobjects(count).BRElength)
ElseIf BREobjects(count).BRElength - Fix(BREobjects(count).BRElength) > 0 Then
BREtimeRight = Right(BREobjects(count).BRElength, 2)
BREobjects(count).BREendTime = BREobjects(count).BREstartTime + (100 * Fix(BREobjects(count).BRElength)) + (BREtimeRight * 60)
End If
BREobjects(count).BREID = BREobjects(count).BREname & " " & BREobjects(count).BREdays & " " & _
BREobjects(count).BREstartTime & " " & BREobjects(count).BREendTime & " " & BREobjects(count).BRElength
Next j
Erase BREdaysString
Next i
'This loop throws an Object variable or with block variable not set error.
'Thrown on the array in the line BREdays = BREobjects(i).BREdays.
Back:
For i = LBound(BREobjects) To UBound(BREobjects)
Dim BREdays As String
BREdays = BREobjects(i).BREdays
If FiveDay = True And BREdays = "Saturday" Or BREdays = "Sunday" Then
Call DeleteElement(i, BREobjects()) 'Deletes the BREppt Object from the BREobjects array
ReDim Preserve BREobjects(UBound(BREobjects) - 1) 'Shrinks the array by one, removing the last one
GoTo Back 'Restarts the loop because the UBound has changed
End If
Debug.Print BREobjects(i).BREID
Next i
If you were to refactor you code using a collection and move some of the property setting to the class module it could reduce the code to something like this.
Sub ExportToPPTButton_Click()
Dim wb As Workbook, ws As Worksheet, iLastRow As Long
Set wb = ThisWorkbook
Set ws = wb.Sheets("Sheet1")
iLastRow = ws.Cells(Rows.count, 1).End(xlUp).Row
Dim BREobjects As New Collection
Dim obj As BREpptObjects2, arDays As Variant
Dim i As Long, dow As Variant, sKey As String, s As String
Dim FiveDays As Boolean
' dictionary to count multiple day/time
Dim dict As Object
Set dict = CreateObject("Scripting.Dictionary")
FiveDays = True
For i = 5 To iLastRow
s = ws.Cells(i, "D")
s = Replace(s, " ", "") 'remove spaces
arDays = Split(s, ",")
For Each dow In arDays
s = LCase(Left(dow, 3))
If (FiveDays = True) And (s = "sat" Or s = "sun") Then
' skip weekends
Else
Set obj = New BREpptObjects2
obj.BREDays = dow
obj.initialise ws.Cells(i, 1)
' avoid duplicate day/time
sKey = obj.BREDays & obj.BREstartTime
obj.BREpic = dict(sKey) + 0
dict(sKey) = dict(sKey) + 1
' add to collection
BREobjects.Add obj, obj.BREID
End If
Next
Next
' set total objects in cell
For Each obj In BREobjects
sKey = obj.BREDays & obj.BREstartTime
obj.BREobjInCell = dict(sKey)
Next
MsgBox BREobjects.count & " objects added to collection"
For Each obj In BREobjects
obj.dump ' debug.print objects
Next
End Sub
Note : I used Public here for demo but use Private in your code
' class BREpptObjects2
Public BREname As String, BRElocation As String, BREcategory As String
Public BREstartTime As String, BREendTime As String
Public BRElength As Double
Public BREDays As String, BREID As String, BREStartRow, BREEndRow
Public BREobjInCell As Integer, BREpic As Integer
Sub initialise(rng As Range)
Dim StartHour As Integer, StartMin As Integer
Dim DurHour As Integer, DurMin As Integer
Dim EndHour As Integer, EndMin As Integer
With rng
BREname = .Offset(0, 0).Value ' A
BRElocation = .Offset(0, 1).Value 'B
BREcategory = .Offset(0, 2).Value 'C
BREstartTime = .Offset(0, 4).Value 'E
BRElength = .Offset(0, 5).Value 'F
End With
StartHour = Int(BREstartTime / 100)
StartMin = BREstartTime Mod 100
DurHour = Fix(BRElength)
DurMin = (BRElength - DurHour) * 60
' set end time
EndHour = StartHour + DurHour
EndMin = StartMin + DurMin
If EndMin > 60 Then
EndMin = EndMin - 60
EndHour = EndHour + 1
End If
BREendTime = EndHour * 100 + EndMin
'Sets the start row number accounting for BREs that start on the half hou
BREStartRow = StartHour + 3
BREEndRow = EndHour + 3
BREID = BREname & " " & BREDays & " " & _
BREstartTime & " " & BREendTime & " " & BRElength
End Sub
Sub dump()
Debug.Print "ID [" & BREID & "]"
Debug.Print "StartTime", BREstartTime, "End TIme", BREendTime, "Length", BRElength
Debug.Print "StartRow", BREStartRow, "EndRow", BREEndRow
Debug.Print "pic", BREpic, "objInCell", BREobjInCell
End Sub
I have a vba module in Excel that had worked a few years ago but not now. I think something has changed (or someone made a change) but I am not sure what. The module is intended to compare the data in Column B (pre-sorted); for each single row or multiple row that matches it outputs a txt file. The first file whether a single row or multiple row is being created but then it stops. It does not go to the next row or group of rows and create a second file (.etc).
The code:
Sub OrderEC()
Dim Header(1 To 50) As Variant
Dim StartRow As Integer
Dim EndRow As Integer
Dim txt As String
Dim Rng1 As Range
Dim Rng2 As Range
Dim Rng3 As Range
Dim Count() As Variant
Dim x As Integer
Dim i As Integer
Dim Users As Integer
For i = 1 To 50
Header(i) = Cells(1, i)
Next
Set Rng1 = Range("B2:B10000")
For Each cell In Rng1
If cell.Value = "" Then GoTo First
ReDim Preserve Count(0 To 1, 0 To x) As Variant
For i = 0 To x - 1
If cell.Value = Count(1, i) Then
Count(0, i) = Count(0, i) + 1
GoTo First
End If
Next i
Count(1, x) = cell.Value
Count(0, x) = 1
x = x + 1
First:
Next
Users = UBound(Count, 2)
EndRow = 1
For s = 1 To Users
StartRow = EndRow
EndRow = StartRow + Count(0, s - 1)
DataFile = "C:\ECorder\" & "BULK_" & Cells(StartRow + 1, 2).Value & "_" & Format(DateTime.Now, "DDMMYYHHMMSS") & ".bulk"
Open DataFile For Output As #1
For U = 1 To 30
Print #1, Header(U) & "=" & Cells(StartRow + 1, U)
Next U
For v = 31 To 40
txt = Header(v) & "="
For i = 1 To Count(0, s - 1)
If i = 1 Then
txt = txt & Cells(StartRow + i, v)
Else
txt = txt & ", " & Cells(StartRow + i, v)
End If
Next i
Print #1, txt
Next v
For w = 41 To 44
Print #1, Header(w) & "=" & Cells(StartRow + 1, w)
Next w
Close #1
Next s
End Sub
I am trying parse a number string and create rows accordingly. On the left of the Example Data picture is an example of the input data with the right being my desired output. I am wanting to insert a unique row of data for each digit within the brackets for each number combination.
Here is an example of the code I used to try to solve the problem.
Option Explicit
Sub example()
Dim num As Variant
Dim x As Variant
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim m As Integer
Dim test As Variant
Dim test2 As Variant
Dim count As Integer
m = 0
For i = 1 To 3
num = Range("C" & 5 + i + m).Value
For j = 1 To Len(num)
test = Mid(num, j)
If Left(Mid(num, j), 1) = "[" Then
For k = 1 To Len(num) - (j + 1)
m = m + 1
Range("C" & 5 + m + i - 1).EntireRow.Insert
test2 = Left(Mid(num, j + k), 1)
Range("C" & 5 + m + i - 1).Value = Left(num, j - 1) + test2
Next k
End If
Next j
Next i
End Sub
Please consider using the following script:
Sub splitcombinations()
Dim rngCell As Range
Set rngCell = ThisWorkbook.Sheets(1).Range("A2")
Dim strCombinationDigits As String, strBaseDigits As String
Dim intCombinationDigitsLen As Integer
Dim x As Integer
Do While rngCell.Value2 <> ""
If InStr(rngCell.Value2, "[") > 0 Then
strCombinationDigits = Mid(rngCell.Value2, InStr(rngCell.Value2, "[") + 1, InStr(rngCell.Value2, "]") - InStr(rngCell.Value2, "[") - 1)
intCombinationDigitsLen = Len(strCombinationDigits)
strBaseDigits = Left(rngCell.Value2, InStr(rngCell.Value2, "[") - 1)
ActiveSheet.Range(rngCell.Offset(1, 0), rngCell.Offset(intCombinationDigitsLen - 1, 0)).EntireRow.Insert
For x = 1 To intCombinationDigitsLen
rngCell.Offset(x - 1, 0).Value2 = strBaseDigits & Mid(strCombinationDigits, x, 1)
rngCell.Offset(x - 1, 1).Value2 = rngCell.Offset(0, 1).Value2
rngCell.Offset(x - 1, 2).Value2 = rngCell.Offset(0, 2).Value2
Next
End If
Set rngCell = rngCell.Offset(intCombinationDigitsLen , 0)
Loop
End Sub
I am new to coding in Access VBA. I am trying to run the following code to extract the selected records from an Access Table and export them to excel but it keeps on showing me the 'Subscript out of range' error.This is the part of the code where I am getting an error. Any help would be appreciated. Thank you
Set db = CurrentDb()
Set rec = db.OpenRecordset("Tablename", dbOpenDynaset)
Dim k As Integer
Dim n() As Variant
Dim m() As Variant
Dim p() As Variant
Dim q() As Variant
Dim size As Integer
k = 10
i = 1
If Not rec.EOF Then
rec.MoveFirst
rec.FindFirst ("Variable1 = '" & Me.Variable1.Value & "' AND Variable2 = " & Me.Variable2.Value & " AND Variable3 = '" & Me.Variable3.Value & "'")
size = DCount("[Field4]", "Tablename", "Variable1 = '" & Me.Variable1.Value & "' AND Variable2 = " & Me.Variable2.Value & " AND Variable3 = '" & Me.Variable3.Value & "'")
ReDim n(size) As String
ReDim m(size) As String
ReDim p(size) As String
ReDim q(size) As String
Do Until rec.EOF
If Not IsNull(rec.Fields("Field4")) Then
n(i) = rec.Fields("Field4")
WKS.Cells((k), 1) = n(i)
End If
If Not IsNull(rec.Fields("Field3")) Then
m(i) = rec.Fields("Field3")
WKS.Cells((k), 2) = m(i)
End If
If Not IsNull(rec.Fields("Field2")) Then
p(i) = rec.Fields("Field2")
WKS.Cells((k), 3) = p(i)
End If
If Not IsNull(rec.Fields("Field1")) Then
q(i) = rec.Fields("Field1")
WKS.Cells((k), 4) = q(i)
End If
rec.MoveNext
k = k + 1
i = i + 1
Loop
End If
Set rec = Nothing