I have the following code. The Loop seems to function well but the ColNum and RowNum lines are only creating 0's the data up to this point is filled out so a blank isn't causing the issue
If Sheets("Control").Range("B6") = "#.#" Then
For i = 1 To ColACount - 2
If FullData(i, 3) <= Sheets("Control").Range("B5") _
And FullData(i, 3) >= Sheets("Control").Range("B4") Then
ColNum = WorksheetFunction.Match(FullData(i, 1), Application.Index(RetGross, 1), 0)
RowNum = WorksheetFunction.Match(FullData(i, 3), Application.Index(RetGross, , 1), 0)
If RetGross(RowNum, ColNum) = "" Then 'Prevents overwriting
RetGross(RowNum, ColNum) = FullData(i, 4)
End If
End If
Next i
End If
I have used Application.Worksheetfunction on the Index and then it really crashes.
Edit: All Code
Sub TransferData()
'Declarations
Dim ReturnWB As String 'File name from Investment metrics
Dim ReturnWBtab1 As String
Dim ReturnWBtab2 As String
Dim ReturnWBtab3 As String
Dim ColACount As Integer 'Total data in column A of Return Puller
Dim FullDataP As Variant ' Pulling data
Dim FullData As Variant ' Building Matrix
Dim Names As Variant
Dim Unique As Integer 'Total Number of unique names
Dim Months As Integer 'Months Specified
Dim StartYear As Integer
Dim EndYear As Integer
Dim StartMonth As Integer
Dim EndMonth As Integer
Dim RetGross As Variant 'Tab data
Dim RetNet As Variant 'Tab data
Dim MValues As Variant 'Tab data
Dim Corner As String 'set the corner value for pasting the array
Dim ColNum As Integer 'Dynamic variable to update matrix
Dim RowNum As Integer 'Dynamic variable to update matrix
Dim First As Integer 'First row for shading - Dynamic and changing
Dim Inceptions As Variant 'Inception Dates
Dim BotRow As Integer 'Testing for Gaps
Dim TopRow As Integer 'Testing for Gaps
'Call Clearing
Workbooks("Return Formatter - Investment Metrics.xlsm").Activate
'Setting Names
ReturnWB = Sheets("Control").Range("B3") & ".xls" 'Excel Name
ReturnWBtab1 = "Pre Fee Returns" 'Tab Name
ReturnWBtab2 = "After Fee Returns" 'Tab Name
ReturnWBtab3 = "Total Fund Market Value" 'Tab Name
'Error Control
On Error GoTo Err1
'Prepping the Dates and Name
StartYear = Year(Sheets("Control").Range("B4"))
EndYear = Year(Sheets("Control").Range("B5"))
StartMonth = Month(Sheets("Control").Range("B4"))
EndMonth = Month(Sheets("Control").Range("B5"))
Months = (EndYear - StartYear + 1) * 12 - (StartMonth - 1) - (12 - EndMonth)
'Find all the unique names/managers and list them
ColACount = WorksheetFunction.CountA(Workbooks(ReturnWB).Sheets(ReturnWBtab1).Range("B:B"))
'Building a Matrix
FullDataP = Workbooks(ReturnWB).Sheets(ReturnWBtab1).Range("B2:E" & ColACount)
FullData = FullDataP
ReDim Preserve FullData(1 To (ColACount - 1), 1 To 5)
'Adding Start Date
FullData(1, 5) = FullData(1, 3)
For i = 2 To (ColACount - 1)
If FullData(i, 1) = FullData(i - 1, 1) Then
FullData(i, 5) = FullData(i - 1, 5)
Else
FullData(i, 5) = FullData(i, 3)
End If
Next i
ReDim Names(1 To 3, 1 To ColACount - 1) 'Setting max size
Names(1, 1) = FullData(1, 1) ' loading first value
Names(2, 1) = FullData(1, 5) ' loading first value
Names(3, 1) = 1 'Tracking the count
x = 1
For i = 1 To (ColACount - 2)
If Names(1, x) <> FullData(i + 1, 1) Then
Names(1, x + 1) = FullData(i + 1, 1)
Names(2, x + 1) = FullData(i + 1, 5)
Names(3, x + 1) = 1 'Tracking the count
x = x + 1
End If
Next i
Unique = WorksheetFunction.Sum(Application.Index(Names, 3)) 'Number of MGRs/Names
ReDim RetGross(1 To Months + 1, 1 To (Unique + 1)) 'Setting Size
ReDim Inceptions(1 To 1, 1 To (Unique + 1)) 'Setting Size
Inceptions(1, 1) = "Inception Date ->"
'Building Dates
For i = 1 To Unique
Inceptions(1, i + 1) = Names(2, i)
Next i
Corner = Sheets("ReturnsGross").Range("A2").Offset(0, Unique).Address
'Dropping Dates
Sheets("ReturnsGross").Range("A2:" & Corner) = Inceptions
'Sheets("ReturnsNet").Range("A2:" & Corner) = Inceptions
'Sheets("MarketValues").Range("A2:" & Corner) = Inceptions
RetGross(1, 1) = "Manager Name ->"
RetGross(2, 1) = WorksheetFunction.EoMonth(DateSerial(Year(Sheets("Control").Range("B4")), Month(Sheets("Control").Range("B4")), 1), 0)
'Building Dates
For i = 1 To Months - 1
RetGross(i + 2, 1) = WorksheetFunction.EoMonth(RetGross(i + 1, 1), 1)
Next i
'Building Names
For i = 1 To Unique
RetGross(1, i + 1) = Names(1, i)
Next i
'RetNet = RetGross 'These Lines will have to change
'MValues = RetGross 'These Lines will have to change
'Code to here function correctly
'Grabbing Data Gross
'Grabbing Data
If Sheets("Control").Range("B6") = "#.#" Then
For i = 1 To ColACount - 2
If FullData(i, 3) <= Sheets("Control").Range("B5") And _
FullData(i, 3) >= Sheets("Control").Range("B4") Then
ColNum = WorksheetFunction.Match(FullData(i, 1), Application.Index(RetGross, 1), 0)
RowNum = WorksheetFunction.Match(FullData(i, 3), Application.Index(RetGross, , 1), 0)
If RetGross(RowNum, ColNum) = "" Then 'Prevents overwriting
RetGross(RowNum, ColNum) = FullData(i, 4)
End If
End If
Next i
End If
Related
I'm having difficulty looping through rows of data between header rows to extract information and then sum the data from a few of the columns below the header row until it reaches the next header row. I am by no means a VBA expert vut Im trying to figure this out on my own and I've stripped down the code to just the basics trying to get this portion to work properly. I'm not sure if I'm taking the right approach to this, but I'm importing the data from the "Raw Data" worksheet into an array ("rdA", currently working fine), then trying to put the header data I need into one temporary array ("rdB", works for the first line, then gives an "Out of Range error) and information from the data rows below it into another temporary array ("rdC") so that I can try to sum data and add the sums to the first temporary array.
The header row always starts with [StartIspn] and I need to extract specific data from the header row (time stamp, user ID, and side). I then need to sum data from a few columns of the rows below, but only for the rows that contain "A13" in column E. The sample image below shows what the raw data looks like. The top gray header row is just in this example to define the columns of data between the headers. My thoughts are that this needs to be loops inside of loops to gather and sum the necessary data, but I'm currently getting stuck trying to get the data to go into the temp arrays. My end goal is to create an array that contains Wafer S/N (column B of rows between headers), Time Stamp, User ID, Wafer Side (all from each header row), and the sum of column F, sum of column H, Min of column I and Max of column J for all rows containing "A13" in column 6 between header rows.
If I can at least get some guidance as to whether or not the approach I'm using is wrong, and how to get past the out of range error when trying to add data to the temporary arrays, I'd be grateful.
Here's what I have so far:
' Define that arrays start with index 1 instead of 0
Option Base 1
' Define that variables must be defined manually and will never be defined automatically
Option Explicit
Sub Create_Report()
' Define variable names and types
Dim chkAnn As String ' Check column 5 for inspection type (A13)
Dim chkHdr As String ' Check column 2 for StartIspn or S/N
Dim fmTot As String ' Sum the total FM area per inspection
Dim fmNum As Long ' Sum the total number of FM particles per inspection
Dim fmMin As Long ' Find the min FM particle size per inspection
Dim fmMax As Long ' Find the max FM particle size per inspection
Dim h As Long ' Row count for FM data
Dim i As Long ' Row count of number of rows being processed
Dim idCol As String ' Time stamp from raw data header line
Dim idPos As Long ' Position of time stamp in raw data header cell
Dim idVal As String ' Time stamp from ecah inspection
Dim j As Long ' Row count for report data array
Dim k As Long ' Row count for debug print
Dim lRow As Long ' Count of number of rows in Raw Data
Dim m As Long ' Row count for debug print
Dim tsCol As String ' Time stamp from raw data header line
Dim tsPos As Long ' Position of time stamp in raw data header cell
Dim tsVal As String ' Time stamp from ecah inspection
Dim rdA() As Variant ' Array of imported Raw Data for parsing
Dim rdB() As Variant ' Array of processed data for report output
Dim rdC() As Variant ' Temp array of FM totals
Dim wfrSN As String ' Wafer serial number from line below header row
Dim wsCol As String ' Time stamp from raw data header line
Dim wsPos As Long ' Position of time stamp in raw data header cell
Dim wsVal As String ' Time stamp from ecah inspection
' Clear all arrays and variables in case report is run again
Erase rdA
ReDim rdA(1, 1)
Erase rdB
ReDim rdB(1, 1)
h = 0
i = 0
j = 0
k = 0
' Find number of populated rows in Raw Data
lRow = Worksheets("Raw Data").Cells(Rows.Count, "B").End(xlUp).Row
' Create array of data from "Raw Data" worksheet
rdA = Worksheets("Raw Data").Range("A1:Q1").Resize(lRow, 17).Value2
' PER INSPECTION GROUP
' Check each line of raw data and extract required info from header row
j = 1
For i = LBound(rdA, 1) To UBound(rdA, 1)
chkHdr = rdA(i, 2)
chkAnn = rdA(i, 5)
Const Hdr = "[StartIspn]"
' Check row for [StartIspn] in rdA Col 2
If InStr(1, chkHdr, Hdr, vbBinaryCompare) > 0 Then
' Collect Wafer Serial Number from next row and add to report array
wfrSN = rdA(i + 1, 2)
rdB(j, 1) = wfrSN
' Collect Time Stamp of inspections and add to report array
tsCol = rdA(i, 3)
tsPos = InStrRev(tsCol, "=")
tsVal = Mid$(tsCol, tsPos + 1)
rdB(j, 2) = tsVal
' Collect User ID and add to report array
idCol = rdA(i, 4)
idPos = InStrRev(idCol, "=")
idVal = Mid$(idCol, idPos + 1)
rdB(j, 3) = idVal
' Collect Wafer Side and add to report array
wsCol = rdA(i, 6)
wsPos = InStrRev(wsCol, "=")
wsVal = Mid$(wsCol, wsPos + 1)
If wsVal = "T" Then
wsVal = "Front"
ElseIf wsVal = "B" Then
wsVal = "Back"
End If
rdB(j, 4) = wsVal
' Resize the report array for the next data set
If j > 0 Then
ReDim Preserve rdB(j - 1)
End If
' Advance to next line in report array (rdB)
j = j + 1
Else
For h = LBound(rdA, 1) To UBound(rdA, 1)
chkAnn = rdA(h, 5)
Const Ann = "A13"
If InStr(1, chkAnn, Ann, vbBinaryCompare) > 0 Then
'Collect Wafer Serial Number
wfrSN = rdA(i, 2)
rdC(h, 1) = wfrSN
' Collect FM Total
fmTot = rdA(i, 6)
rdC(h, 2) = fmTot
' Collect # of FM Particles
fmNum = rdA(i, 8)
rdC(h, 3) = fmNum
' Collect Min Particle Size
fmMin = rdA(i, 9)
rdC(h, 4) = fmMin
' Collect Max Particle Size
fmMax = rdA(i, 10)
rdC(h, 5) = fmMax
' Advance to next line in temp array (rdC)
h = h + 1
End If
Next h
Next i
For k = LBound(rdB, 1) To UBound(rdB, 1)
Debug.Print rdB(k, 1) & ", " & _
rdB(k, 2) & ", " & _
rdB(k, 3) & ", " & _
rdB(k, 4)
Next k
For m = LBound(rdC, 1) To UBound(rdC, 1)
Debug.Print rdC(m, 1) & ", " & _
rdC(m, 2) & ", " & _
rdC(m, 3) & ", " & _
rdC(m, 4) & ", " & _
rdC(m, 5)
Next m
End Sub
Updated and working Code:
Sub Create_Report()
Dim vDB, vResult(), vSum1(), vSum2(), vMin(), vMax()
Dim Ws As Worksheet, wsResult As Worksheet
Dim s As String, i As Long, n As Long, r As Long
Dim k As Integer
Const Hdr = "[StartIspn]"
Const Ann = "A13"
Set Ws = Sheets("Raw Data")
Set wsResult = Sheets("AOI Inspection Summary")
vDB = Ws.Range("a1").CurrentRegion
r = UBound(vDB, 1)
For i = 1 To r
If InStr(vDB(i, 2), Hdr) Then
n = n + 1
ReDim Preserve vResult(1 To 9, 1 To n)
vResult(1, n) = n
vResult(2, n) = vDB(i + 1, 2)
vResult(3, n) = Replace(vDB(i, 3), "Time=", "")
vResult(4, n) = Replace(vDB(i, 4), "User=", "")
s = Replace(vDB(i, 6), "Side=", "")
If s = "T" Then
vResult(5, n) = "Front"
Else
vResult(5, n) = "Back"
End If
If k > 0 Then
vResult(6, n - 1) = WorksheetFunction.Sum(vSum1)
vResult(7, n - 1) = WorksheetFunction.Sum(vSum2)
vResult(8, n - 1) = WorksheetFunction.Min(vMin)
vResult(9, n - 1) = WorksheetFunction.Max(vMax)
k = 0
End If
Else
If InStr(vDB(i, 5), Ann) Then
k = k + 1
ReDim Preserve vSum1(1 To k)
ReDim Preserve vSum2(1 To k)
ReDim Preserve vMin(1 To k)
ReDim Preserve vMax(1 To k)
vSum1(k) = vDB(i, 6)
vSum2(k) = vDB(i, 8)
vMin(k) = vDB(i, 9)
vMax(k) = vDB(i, 10)
End If
End If
Next i
vResult(6, n) = WorksheetFunction.Sum(vSum1)
vResult(7, n) = WorksheetFunction.Sum(vSum2)
vResult(8, n) = WorksheetFunction.Min(vMin)
vResult(9, n) = WorksheetFunction.Max(vMax)
With wsResult 'array Result write on sheet
.Range("b21").CurrentRegion.Offset(2).ClearContents
.Range("b23").Resize(n, 9) = WorksheetFunction.Transpose(vResult)
End With
End Sub
Try this.
Sub test()
Dim vDB, vResult(), vSum(), vMin(), vMax()
Dim Ws As Worksheet, wsResult As Worksheet
Dim s As String, i As Long, n As Long, r As Long
Dim k As Integer
Const Hdr = "[StartIspn]"
Set Ws = Sheets("Raw Data")
Set wsResult = Sheets("AOI Inspection Summary")
vDB = Ws.Range("a1").CurrentRegion
r = UBound(vDB, 1)
For i = 2 To r '<~~ if your Raw data row 1 data is Row#, Watar S/n.... i start 2 else 1
If InStr(vDB(i, 2), Hdr) Then
n = n + 1
ReDim Preserve vResult(1 To 9, 1 To n)
vResult(1, n) = n
vResult(2, n) = vDB(i + 1, 2)
vResult(3, n) = Replace(vDB(i, 3), "Time=", "") 'time
vResult(4, n) = Replace(vDB(i, 4), "User=", "") 'Positon
s = Replace(vDB(i, 6), "Sided=", "")
If s = "T" Then
vResult(5, n) = "Front"
Else
vResult(5, n) = "Back"
End If
If k > 0 Then
vResult(6, n - 1) = WorksheetFunction.Sum(vSum)
vResult(7, n - 1) = 37 '<~~ what mean # of particle
vResult(8, n - 1) = WorksheetFunction.Min(vMin)
vResult(9, n - 1) = WorksheetFunction.Max(vMax)
k = 0
End If
Else
k = k + 1
ReDim Preserve vSum(1 To k)
ReDim Preserve vMin(1 To k)
ReDim Preserve vMax(1 To k)
vSum(k) = vDB(i, 6)
vMin(k) = vDB(i, 9)
vMax(k) = vDB(i, 10)
End If
Next i
vResult(6, n) = WorksheetFunction.Sum(vSum)
vResult(7, n) = 37 '<~~ what mean # of particle
vResult(8, n) = WorksheetFunction.Min(vMin)
vResult(9, n) = WorksheetFunction.Max(vMax)
With wsResult 'array Result write on sheet
.Range("b21").CurrentRegion.Offset(2).ClearContents
.Range("b23").Resize(n, 9) = WorksheetFunction.Transpose(vResult)
End With
End Sub
Sub FallOrSpringsemester()
Dim enrollPeriod As String
Dim i As Integer
Dim LastRow As Integer
Dim w As Worksheet
Dim text As String
Set w = Sheets.Add(after:=Sheets(Sheets.Count))
w.Name = "oldest Students"
Worksheets("oldest Students").Cells(1, 1) = "Student_ID"
Worksheets("oldest Students").Cells(1, 2) = "Enroll_Date"
Worksheets("oldest Students").Cells(1, 3) = "Program_Type_Name"
Worksheets("oldest Students").Cells(1, 4) = "Enrollment_Period"
LastRow = Worksheets("Base").Range("D" & Rows.Count).End(xlUp).Row
For i = 2 To LastRow
Worksheets("oldest students").Cells(i, 1) = Worksheets("Base").Cells(i, 12)
Worksheets("oldest students").Cells(i, 2) = Worksheets("Base").Cells(i, 4)
Worksheets("oldest students").Cells(i, 3) = Worksheets("Base").Cells(i, 11)
Above this coding I ofc have my dimed variables and also coding for creating a new sheet.
I have trouble with this part as it will no do the calculations and tells me there is an error
"13": type miss match
If enrollPeriod Mod 2 = 0 Then
Worksheets("oldest Students").Cells(i, 2) = "Spring"
enrollPeriod = enrollPeriod + 1
Worksheets("oldest Students").Cells(i, 1) = 2018 - ((138 - enrollPeriod) / 2)
Else
Worksheets("oldest Students").Cells(i, 2) = "Fall"
Worksheets("oldest Students").Cells(i, 1) = 2018 - ((138-enrollPeriod) / 2)
End if
Next
End Sub
I think enrollPperiod should be an integer... that should fix it
I received help in solving a previous question. I would like to solve this problem similarly.
So the situation is similar to a Countifs function, in that I would like it to count if a range equals a certain building, as well as if the date and time that is offset equals a certain date. For example, if the cell in "C1" = "Irving Building" And if the value in "K1" = "Monday" Then I would like it to display in "S1". More specifically if "C1" = "Irving Building" then I want it to count into whatever day and time that corresponds with it, in Column K.
Private Sub TimeAndDate()
Dim n As Double
Dim rep As Worksheet
Dim ws As Worksheet
Dim LastRow As Double
Set rep = Worksheets("Report")
rep.Columns("K:L").ClearContents
For n = 1 To ThisWorkbook.Sheets.Count
Set ws = Worksheets(n)
If IsNumeric(ws.Name) Then
LastRow = rep.Range("K1", rep.Range("K1").End(xlDown)).Rows.Count
LastRow = LastRow + 1
If rep.Range("K1") = "" Then
ws.Range("C2", ws.Range("C2").End(xlDown)).Copy _
Destination:=rep.Range("K1")
ws.Range("C2", ws.Range("C2").End(xlDown)).Copy _
Destination:=rep.Range("L1")
Else:
ws.Range("C2", ws.Range("C2").End(xlDown)).Copy _
Destination:=rep.Range("K" & LastRow)
ws.Range("C2", ws.Range("C2").End(xlDown)).Copy _
Destination:=rep.Range("L" & LastRow)
End If
End If
Next n
Dim rDts As Range
Dim vDts As Variant
Dim vCnts As Variant
Dim vAP As Variant 'for the AM PM count
Dim vDbld As Variant 'for the date by building
Dim vTbld As Variant 'for thee time by building
Dim i As Long, J As Long
'read dates into array -- faster processing
With rep
vDts = .Range(.Cells(1, 11), .Cells(.Rows.Count, 11).End(xlUp))
End With
'Results array
ReDim vCnts(1 To 7, 1 To 2)
vCnts(1, 1) = "Sunday"
vCnts(2, 1) = "Monday"
vCnts(3, 1) = "Tuesday"
vCnts(4, 1) = "Wednesday"
vCnts(5, 1) = "Thursday"
vCnts(6, 1) = "Friday"
vCnts(7, 1) = "Saturday"
ReDim vAP(1 To 2, 1 To 2)
vAP(1, 1) = "AM"
vAP(2, 1) = "PM"
ReDim vDbld(1 To 13, 1 To 2)
vDbld(1, 1) = "Irving Building"
vDbld(2, 1) = "Memorial Building"
vDbld(3, 1) = "West Tower"
vDbld(4, 1) = "Witting Surgical Center"
vDbld(5, 1) = "Madison Irving Surgical Center"
vDbld(6, 1) = "Marley Education Center"
vDbld(7, 1) = "410 South Crouse"
vDbld(8, 1) = "Physicians Office Building"
vDbld(9, 1) = "Crouse Business Center"
vDbld(10, 1) = "Commonwealth Place"
vDbld(11, 1) = "Irving - Memorial Connector"
vDbld(12, 1) = "Crouse Garage"
vDbld(13, 1) = "CNY Medical Center"
'Do the counts
For i = 1 To UBound(vDts, 1)
J = Weekday(vDts(i, 1))
vCnts(J, 2) = vCnts(J, 2) + 1
If Hour(vDts(i, 1)) < 12 Then
vAP(1, 2) = vAP(1, 2) + 1
Else
vAP(2, 2) = vAP(2, 2) + 1
End If
Next i
'output the results
rep.Range("E1:E14").Copy rep.Range("Q1")
rep.Range("N2:N8").Copy
rep.Range("R1").PasteSpecial xlPasteAll, xlPasteSpecialOperationNone, _
False, True
rep.Range("N11:N12").Copy
rep.Range("Y1").PasteSpecial xlPasteAll, xlPasteSpecialOperationNone, _
False, True
rep.Range("N1") = "DATE"
rep.Range("O1") = "COUNT"
rep.Range("N10") = "TIME"
rep.Range("O10") = "COUNT"
rep.Range("N2:O8").Value = vCnts
rep.Range("N11:O12").Value = vAP
The part that I am needing help on is this part here. These are the variants that I'd like to use, but like I said, earlier, I am unsue as to how to do this without running a ton of countifs statements.
Dim vDbld As Variant 'for the date by building
ReDim vDbld(1 To 13, 1 To 2)
vDbld(1, 1) = "Irving Building"
vDbld(2, 1) = "Memorial Building"
vDbld(3, 1) = "West Tower"
vDbld(4, 1) = "Witting Surgical Center"
vDbld(5, 1) = "Madison Irving Surgical Center"
vDbld(6, 1) = "Marley Education Center"
vDbld(7, 1) = "410 South Crouse"
vDbld(8, 1) = "Physicians Office Building"
vDbld(9, 1) = "Crouse Business Center"
vDbld(10, 1) = "Commonwealth Place"
vDbld(11, 1) = "Irving - Memorial Connector"
vDbld(12, 1) = "Crouse Garage"
vDbld(13, 1) = "CNY Medical Center"
I apologize if this is confusing, I am not completely sure how to word it, thanks in advance.
This is an example of what I'd like it to look like:
What you simply can is to check with Application.Match if the string is in the array and it will give back the index, because this function can only handle one dimensional arrays, there is another function that will give back one dimension of the array. After that you can check the offset and do something with it like this:
Dim mindex as Variant
mindex = Application.Match(rDts(i, 3), Only1D(vDbld, 1), 0)
If Not IsError(mindex) Then
'do stuff i.e
vDbld(mindex, 2) = vDbld(mindex, 2) + 1
End If
Function Only1D(arr As Variant, d As Long)
Dim size As Long: size = UBound(arr, d)
Dim arr2 As Variant
ReDim arr2(1 To size)
For i = 1 To size
arr2(i) = arr(i, d)
Next
Only1D = arr2
End Function
I have created a code for getting unique value from a column which is filled with date and from that unique column i have compare whether it is Sunday or Monday or Tuesday or etc and if it falls in between two time stamp [2:00:00 am to 2:59:59 am] i increment but if on same date for example 1/5/2014 it falls in two time stamp again[2:00:00 am - 2:59:59 am] i should not increment and if in the same date it falls in another time stamp it should increment that too only once.
It is working for 50 -100 rows but for 200k of rows it is hanging.
Private Sub CommandButton1_Click()
Range("I2:O25") = ""
Set Range1 = Range("B:B")
Dim dates As Variant
Dim Array1() As Variant
Dim MyArray1(24, 7) As Integer
Array1 = UniqueItems(Range1, False)
For Each dates In Array1
If Not (dates = "" Or dates = "Date") Then
For y = 2 To Range("B2").End(xlDown).Row
If (dates = (Cells(y, 2))) Then
For f = 2 To Range("f2").End(xlDown).Row
If ((TimeValue(Cells(y, 4).Text) >= TimeValue(Cells(f, 6).Text)) And (TimeValue(Cells(y, 4).Text) <= TimeValue(Cells(f, 7).Text))) Then
If (Cells(y, 3) = "Sunday") Then
' Cells(f, 12) = 1
Dim g As Integer
g = f - 2
MyArray1(g, 0) = 1
End If
If (Cells(y, 3) = "Monday") Then
' Cells(f, 12) = 1
g = f - 2
MyArray1(g, 1) = 1
End If
If (Cells(y, 3) = "Tuesday") Then
' Cells(f, 12) = 1
g = f - 2
MyArray1(g, 2) = 1
End If
If (Cells(y, 3) = "Wednesday") Then
' Cells(f, 12) = 1
g = f - 2
MyArray1(g, 3) = 1
End If
If (Cells(y, 3) = "Thursday") Then
' Cells(f, 12) = 1
g = f - 2
MyArray1(g, 4) = 1
End If
If (Cells(y, 3) = "Friday") Then
' Cells(f, 12) = 1
g = f - 2
MyArray1(g, 5) = 1
End If
If (Cells(y, 3) = "Saturday") Then
' Cells(f, 12) = 1
g = f - 2
MyArray1(g, 6) = 1
End If
End If
Next f
End If
Next y
For k = 0 To 7
For x = 0 To 23
Dim cellsval As Integer
Dim dayvals As Integer
cellsval = x + 2
dayvals = k + 9
Cells(cellsval, dayvals) = Cells(cellsval, dayvals) + MyArray1(x, k)
MyArray1(x, k) = 0
Next x
Next k
End If
Next
'For x = 2 To Range("H2").End(xlDown).Row
' For y = 2 To Range("A2").End(xlDown).Row
' If (Cells(y, 2) = Cells(x, 8)) Then
' If ((TimeValue(Cells(y, 4).Text) >= TimeValue(Cells(16, 6).Text)) And (TimeValue(Cells(y, 4).Text) <= TimeValue(Cells(16, 7).Text))) Then
' If (Cells(y, 3) = "Wednesday") Then
' Cells(x, 22) = 1
' End If
' End If
' End If
' Next y
'Next x
End Sub
Function RetTime(IntTime As Long) As Date
RetTime = TimeSerial(Int(IntTime / 10000), Int((IntTime Mod 10000) / 100), (IntTime Mod 100))
End Function
Function UniqueItems(ArrayIn, Optional Count As Variant) As Variant
' Accepts an array or range as input
' If Count = True or is missing, the function returns the number of unique elements
' If Count = False, the function returns a variant array of unique elements
Dim Unique() As Variant ' array that holds the unique items
Dim Element As Variant
Dim i As Integer
Dim FoundMatch As Boolean
' If 2nd argument is missing, assign default value
If IsMissing(Count) Then Count = True
' Counter for number of unique elements
NumUnique = 0
' Loop thru the input array
For Each Element In ArrayIn
FoundMatch = False
' Has item been added yet?
For i = 1 To NumUnique
If Element = Unique(i) Then
FoundMatch = True
Exit For '(exit loop)
End If
Next i
AddItem:
' If not in list, add the item to unique list
If Not FoundMatch And Not IsEmpty(Element) Then
NumUnique = NumUnique + 1
ReDim Preserve Unique(NumUnique)
Unique(NumUnique) = Element
End If
Next Element
' Assign a value to the function
If Count Then UniqueItems = NumUnique Else UniqueItems = Unique
End Function
I have taken the liberty of cleaning up your code a bit, I dropped a couple of comments in there to show you the changes and I have indented it properly.
Option Explicit
Private Sub CommandButton1_Click()
Dim dates As Variant, Array1() As Variant, MyArray1(24, 7) As Long, g As Long, MyWeekday As Variant, X As Long, K As Long, F As Long, Y As Long, Range1 As Range
MyWeekday = Array("Sunday", "Monday", "Tuesday", "Wednesday", "Thursday", "Friday", "Saturday")
Range("I2:O25").ClearContents
Set Range1 = Range("B:B")
Array1 = UniqueItems(Range1, False)
For Each dates In Array1
If Not (dates = "" Or dates = "Date") Then
For Y = 2 To Range("B" & Rows.Count).End(xlUp).Row
If (dates = (Cells(Y, 2))) Then
For F = 2 To Range("f" & Rows.Count).End(xlUp).Row
If ((TimeValue(Cells(Y, 4).Text) >= TimeValue(Cells(F, 6).Text)) And (TimeValue(Cells(Y, 4).Text) <= TimeValue(Cells(F, 7).Text))) Then
For X = LBound(MyWeekday) To UBound(MyWeekday)
If (Cells(Y, 3) = MyWeekday(X)) Then
g = F - 2
MyArray1(g, X) = 1
End If
Next
End If
Next
End If
Next
For K = 0 To 7
For X = 0 To 23
Cells(X + 2, K + 9) = Cells(X + 2, K + 9) + MyArray1(X, K)
MyArray1(X, K) = 0
Next
Next
End If
Next
End Sub
Function RetTime(IntTime As Long) As Date
RetTime = TimeSerial(Int(IntTime / 10000), Int((IntTime Mod 10000) / 100), (IntTime Mod 100))
End Function
Function UniqueItems(ArrayIn, Optional Count As Variant) As Variant
' Accepts an array or range as input
' If Count = True or is missing, the function returns the number of unique elements
' If Count = False, the function returns a variant array of unique elements
Dim Unique() As Variant, Element As Variant, i As Long, FoundMatch As Boolean, NumUnique As Long
' If 2nd argument is missing, assign default value
If IsMissing(Count) Then Count = True
' Counter for number of unique elements
NumUnique = 0
' Loop thru the input array
For Each Element In ArrayIn
FoundMatch = False
' Has item been added yet?
For i = 1 To NumUnique
If Element = Unique(i) Then
FoundMatch = True
Exit For '(exit loop)
End If
Next i
'AddItem - You don't need this as a GoTo heading you can jump to, keep it commented out
' If not in list, add the item to unique list
If Not FoundMatch And Not IsEmpty(Element) Then
NumUnique = NumUnique + 1
ReDim Preserve Unique(NumUnique)
Unique(NumUnique) = Element
End If
Next Element
' Assign a value to the function
If Count Then UniqueItems = NumUnique Else UniqueItems = Unique
End Function
Please post try the code I posted and see if it does the same as your code did, if so then we can begin making the changes you need.
I'm trying to add the items from a list to some rows in an Excel Sheet.
I tried to do it this way:
Dim Rand As Long
Dim ws As Worksheet
Set ws = Worksheets("Necmontage")
Rand = ws.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
Range(ws.Cells(Rand, 1), ws.Cells(Rand + necesar.ListCount - 1, 1)).Merge
ws.Cells(Rand, 1) = "K"
Range(ws.Cells(Rand, 2), ws.Cells(Rand + necesar.ListCount - 1, 2)).Merge
ws.Cells(Rand, 2) = "Montage"
Range(ws.Cells(Rand, 3), ws.Cells(Rand + necesar.ListCount - 1, 3)).Merge
ws.Cells(Rand, 3) = comanda.Caption
Dim i As Integer
i = 0
Do While i = necesar.ListCount - 1
ws.Cells(Rand + i, 4) = necesar.List(i, 0)
i = i + 1
Loop
End Sub
It adds all the values I want except the values from the List (where I do that While Loop). I don't know why but it doesn't take the values. Any idea about this problem?
Did you mean in your code:
Do While i <= necesar.ListCount - 1 'instead of =
ws.Cells(Rand + i, 4) = necesar.List(i, 0)
i = i + 1
Loop
Btw, you can see in debug mode by putting a breakpoint on the Do While line if the program goes where you wanted it to.