I'm trying to have a for loop that takes my weeks and then another for loop that looks at my product to calculate the sales for this year, last year and then the difference. I am getting 0's for all of the weeks except for the current week, any idea what is wrong with my code? Thanks
Sub Weekly_Recap()
Dim h, d As Worksheet
Dim myarray(), answers() As Variant
'Dim week, datarange As Range
Dim D1, i As Long
Set h = Worksheets("Helper")
Set d = Worksheets("Data")
myarray = d.Range("P2:P51")
D1 = UBound(myarray, 1)
ReDim answers(1 To D1, 1 To 3)
For i = 1 To D1
If myarray(i, 1) <= h.Range("A1") Then
For j = 1 To 17
answers(i, 1) = Application.WorksheetFunction.SumIfs(d.Range("G:G"), d.Range("B:B"), myarray(i, 1), d.Range("F:F"), h.Cells(j, 4))
answers(i, 2) = Application.WorksheetFunction.SumIfs(d.Range("H:H"), d.Range("B:B"), myarray(i, 1), d.Range("F:F"), h.Cells(j, 4))
answers(i, 3) = (answers(i, 1) - answers(1, 2)) / answers(i, 2)
If h.Cells(j, 4) = "FLAVORED/FUNCTIONAL WATER" Then
h.Range(h.Range("F2"), h.Range("F2").Offset(D1, 2)).Value = answers
ElseIf h.Cells(j, 4) = "SALTY BAGGED/CANISTER SNACKS" Then
h.Range(h.Range("K2"), h.Range("K2").Offset(D1, 2)).Value = answers
End If
Next j
End If
Next i
End Sub
Kinda hard to understand what you are trying to do. When I tried to run your code in debug mode I noticed that line with offset is overwriting data in previous lines, and that is where you are getting all 0's. In lets say loop i = 1 and j = 1 you get some value, but in i = 1 and j = 2 you don't (sumif returns 0) and then you overwrite it in variable answers and then paste it in worksheet, at the end only last one has not been overwritten.
You need swap the loops to calculate all the weeks for each product in turn otherwise the figure for week1/product1 will be overwritten by week1/product2 then week1/product3 etc.
Option Explicit
Sub Sales()
Dim arWeeks, NoOfWeeks As Long, iLastWeek As Long
Dim rngSales1 As Range, rngSales2 As Range
Dim rngWeek As Range, rngProduct As Range
Dim iWeek As Long, sProduct As String
Dim h As Worksheet, d As Worksheet
Dim j As Long, i As Long
Set h = Worksheets("Helper")
Set d = Worksheets("Data")
Set rngSales1 = d.Range("G:G")
Set rngSales2 = d.Range("H:H")
Set rngWeek = d.Range("B:B")
Set rngProduct = d.Range("F:F")
arWeeks = d.Range("P2:P51")
iLastWeek = h.Range("A1").Value
NoOfWeeks = UBound(arWeeks)
ReDim answers(1 To NoOfWeeks, 1 To 3) 'yr1,yr2,diff
For j = 1 To 17 ' products
sProduct = h.Cells(j, 4)
For i = 1 To NoOfWeeks ' weeks
iWeek = arWeeks(i, 1)
If iWeek <= iLastWeek Then
With Application.WorksheetFunction
answers(i, 1) = .SumIfs(rngSales1, rngWeek, iWeek, rngProduct, sProduct)
answers(i, 2) = .SumIfs(rngSales2, rngWeek, iWeek, rngProduct, sProduct)
End With
If answers(i, 2) <> 0 Then
answers(i, 3) = (answers(i, 1) - answers(1, 2)) / answers(i, 2)
End If
End If
Next i
If sProduct = "FLAVORED/FUNCTIONAL WATER" Then
h.Range("F2").Resize(NoOfWeeks, 3).Value = answers
ElseIf sProduct = "SALTY BAGGED/CANISTER SNACKS" Then
h.Range("k2").Resize(NoOfWeeks, 3).Value = answers
End If
Next j
MsgBox "Done ", vbInformation
End Sub
Related
This should be easy and I think I am almost there. I would like to count how many times an entry repeats itself within a certain array. The array will be populated from a range. Eventually if the number of the count is more than 4, I would like to insert "Excess", otherwise if less than 4, I would like to insert "Insufficient", else is "complete". Unfortunately, even though I have learnt to do these calculations without using Arrays, I find some difficulties when switching to Arrays.
How the code should look like
Sub test()
Dim MyArray() As Variant, Countarrays() As Variant, Result() As Variant
Dim r As Range
Dim rows As Integer
Worksheets("Sheet1").Activate
Set r = Range("B2", Range("B1").End(xlDown))
MyArray = Range("B2", Range("B1").End(xlDown))
rows = Range("B2", Range("B1").End(xlDown)).Count
For i = 0 To rows
For j = 0 To rows
Countarrays(i, 1) = WorksheetFunction.CountIf(r, MyArray(i))
If (Countarrays(i, 1).value) > 4 Then Result(j, 1) = "Excess"
ElseIf (Countarrays(i, 1).value) < 4 Then Result(j, 1) = "Insufficient"
ElseIf (Countarrays(i, 1).value) = 4 Then Result(j, 1) = "Complete"
Next j
Next i
End Sub
This should do the trick:
Option Explicit
Sub Test()
Dim MyArray, DictDuplicates As New Scripting.Dictionary, i As Long
With ThisWorkbook.Sheets("Sheet1") 'change if needed
MyArray = .Range(.Cells(2, 1), .Cells(2, 2).End(xlDown))
For i = LBound(MyArray) To UBound(MyArray) 'loop to store all the items and how many times do they repeat
If Not DictDuplicates.Exists(MyArray(i, 2)) Then 'if doesn't exists will store it
DictDuplicates.Add MyArray(i, 2), 1
Else 'if it does exists will increment its item value
DictDuplicates(MyArray(i, 2)) = DictDuplicates(MyArray(i, 2)) + 1
End If
Next i
For i = LBound(MyArray) To UBound(MyArray) 'loop to give back the result
Select Case DictDuplicates(MyArray(i, 2))
Case Is > 4
MyArray(i, 1) = "Excess"
Case Is = 4
MyArray(i, 1) = "Complete"
Case Is < 4
MyArray(i, 1) = "Insufficient"
End Select
Next i
.Range(.Cells(2, 1), .Cells(2, 2).End(xlDown)) = MyArray
End With
End Sub
Note that for the DictDuplicates to work, you need to check the Microsoft Scripting Runtime library.
Is there a way to have this script form the entire array based off the rows I want it to extract based on the IF Statement?
I know this finds a name on the Mgrs worksheet, and finds those rows in the Data worksheet, but then it directly prints it after forming the array. Can I have this code store all of the data, and then wait to print the data on a template that I format myself?
Option Explicit
Sub CIB_Cuts()
Dim j As Long, k As Long, x As Long
Dim varArray() As Variant
Dim varArray2() As Variant
ReDim varArray(1 To 19, 1 To 1)
Dim strManager As String, strEC As String, strLogin As String
Dim BASEPATH As String, strNewPath As String, strFileName As String
Dim Wb As Workbook
Dim mgrRow As Long
Dim colManager As Long
colManager = 3
Dim colLogin As Long
colLogin = 4
Dim colEC As Long
colEC = 5
BASEPATH = "M:\Final Files\"
Call speedupcode(True)
For mgrRow = 2 To ThisWorkbook.Worksheets("Mgrs").UsedRange.Rows.Count
If ThisWorkbook.Worksheets("Mgrs").Cells(mgrRow, 3) <> "" Then
strManager = ThisWorkbook.Worksheets("Mgrs").Cells(mgrRow, 3)
With ThisWorkbook.Worksheets("Data")
ReDim varArray(1 To UBound(varArray, 1), 1 To 1)
x = 1
For k = 1 To UBound(varArray, 1)
varArray(k, x) = .Cells(1, k)
Next
For j = 2 To .UsedRange.Rows.Count + 1
If strManager = .Cells(j, colManager) Then
x = x + 1
ReDim Preserve varArray(1 To UBound(varArray, 1), 1 To x)
For k = 1 To UBound(varArray, 1)
If k = 1 Then
varArray(1, x) = CStr(Format(.Cells(j, k), "000000000"))
Else
varArray(k, x) = .Cells(j, k)
End If
strEC = .Cells(j, colEC)
strManager = .Cells(j, colManager)
strLogin = .Cells(j, colLogin)
Next
End If
Next
End With
strFileName = strLogin & " - " & strManager & " - " & "Shift Differential Validation" & ".xlsx"
ReDim varArray2(1 To UBound(varArray, 2), 1 To UBound(varArray, 1))
Set Wb = Workbooks.Add(XlWBATemplate.xlWBATWorksheet)
With Wb
With .Worksheets("Sheet1")
.Columns(1).NumberFormat = "#"
.Columns(15).NumberFormat = "0%"
For j = 1 To UBound(varArray, 2)
For k = 1 To UBound(varArray, 1)
varArray2(j, k) = varArray(k, j)
Next
Next
.Range(.Cells(1, 1), .Cells(UBound(varArray, 2), UBound(varArray, 1))) = varArray2
Call DataValidation
Call Header
.Range("C2").Select
ActiveWindow.FreezePanes = True
.Cells.EntireColumn.AutoFit
.Rows("1:1").Font.Bold = True
Call protect
End With
.SaveAs strNewPath & strFileName, Password:="password", FileFormat:=51
.Saved = True
.Close
End With
Set Wb = Nothing
End If
Next
Call speedupcode(False)
End Sub
You could store the array each time in an overarching array or a collection and loop that at the end...
Public Sub test()
Dim varArray2() As Variant, results As Collection
'other code..
Set results = New Collection
results.Add varArray2
End Sub
You could also use Select Case , or something distinctive during the loop, to determine a key and populate a dictionary with the arrays as values which might make retrieval of specific items easier.
I'm comparing some information contained in 2 different sheets. The validation is working as expected. From that comparison I have to get two values, it was working with one, because I was populating a 1D array. Now that I got a 2D array it doesn't seem to be getting populated and I can't figure why. Here is my code.
Private Sub btngenerar_Click()
Dim wscasos As Worksheet
Dim wstareas As Worksheet
Dim r1 As Range
Dim r2 As Range
Dim cel1 As Range
Dim cel2 As Range
Dim vrep As Integer
Dim i As Integer
Dim j As Integer
Dim flag As Integer
Dim resultado() As Variant
Dim x As Long
Set wscasos = ThisWorkbook.Worksheets("Filtrados")
Set wstareas = ThisWorkbook.Worksheets("Tareas")
With wscasos
Set r1 = .Range("B2", .Cells(.Rows.Count, .Columns("B:B").Column).End(xlUp))
End With
With wstareas
Set r2 = .Range("C2", .Cells(.Rows.Count, .Columns("C:C").Column).End(xlUp))
End With
On Error Resume Next
For Each cel1 In r1
With Application
Set cel2 = .Index(r2, .Match(cel1.Value, r2, 0))
If Err = 0 Then
vrep = .WorksheetFunction.CountIf(r2, cel1.Value)
For i = 1 To vrep
If cel2.Offset(i - 1, 4) = "Cerrado" Then
flag = flag + 1
Else
Exit For
End If
Next i
If flag = vrep Then
ReDim Preserve resultado(x, 1)
resultado(x, 0) = cel1.Value
resultado(x, 1) = cel1.Offset(, 8).Value
x = x + 1
End If
End If
Err.Clear
flag = 0
End With
Next cel1
i = 0
j = 0
Sheets("Reporte").Range("A1").Select
For i = LBound(resultado, 1) To UBound(resultado, 1)
For j = LBound(resultado, 2) To UBound(resultado, 2)
ActiveCell.Offset(i - 1, j - 1).Value = resultado(i, j)
Next j
Next i
End Sub
I'm a bit rusty and prolly it's a simple fix, I hope you can help me out to find the error. Thanks a lot in advance. Here is where I populate the array:
If flag = vrep Then
ReDim Preserve resultado(x, 1)
resultado(x, 0) = cel1.Value
resultado(x, 1) = cel1.Offset(, 8).Value
x = x + 1
End If
first of all, i'd like to say, i've sarched thorugh the net, but i haven't run into such a thing. i've seen collection of collections, or array of arrays, but not a collection of array.
what i want to do is, to collect ID's in collections for each District. Finally, i will join the values in the collections with Join function and ";" as delimiter, and then print them in a range of 4 column as a lookup list, for each class. For example;
Class2(0) will include 54020 and 30734, class2(1) will include 58618, class1(4) will include none, class3(7) will include 35516,34781 and 56874, and so on.
i want to loop through column C and put a select case statment to check the class and then assign the values to collections
Sub dict_coll()
Dim class1() As New Collection
Dim class2() As New Collection
Dim class3() As New Collection
Dim class4() As New Collection
Dim dict As New Scripting.Dictionary
Set dRange = range(range("a2"), range("a2").End(xlDown))
i = 0
For Each d In dRange
If Not dict.Exists(d.Value) Then
dict.Add key:=d.Value, item:=i
i = i + 1
End If
Next d
Set cRange = range(range("c2"), range("c2").End(xlDown))
For Each c In cRange
Select Case c.Value
Case "class1"
class1(dict(c.offset(0,-2).value)).Add c.Offset(0, 1).Value 'fails here
Case "class2"
class2(dict(c.offset(0,-2).value)).Add c.Offset(0, 1).Value 'fails here
Case "class3"
class3(dict(c.offset(0,-2).value)).Add c.Offset(0, 1).Value 'fails here
Case Else
class4(dict(c.offset(0,-2).value)).Add c.Offset(0, 1).Value 'fails here
End Select
Next c
End Sub
and what i want to see is as foloowing:
is there any easier and proper way of what i wanna do? any help wil be appreciated.
thanks
I didnt see that sb variable defined in your code.
Anyway, for me I see a case of straightforward arrays: There is fixed dimension of classes so it good enough for me. Furthermore, you can print back to worksheet so easily.
Public Sub test()
Const strPrefix = "class"
Dim districtRange As Range, outputRange As Range, r As Range
Dim arr() As String
Dim i As Long, j As Long, x As Long, y As Long
Dim district As String, str As String, idVal As String
Dim arr2 As Variant
Application.ScreenUpdating = False
ReDim arr(1 To 5, 1 To 1)
arr(1, 1) = "District"
arr(2, 1) = "Class 1"
arr(3, 1) = "Class 2"
arr(4, 1) = "Class 3"
arr(5, 1) = "Class 4"
Set districtRange = Range(Range("A2"), Range("C2").End(xlDown))
arr2 = districtRange.Value
For x = LBound(arr2, 1) To UBound(arr2, 1)
district = arr2(x, 1)
i = Val(Mid(arr2(x, 3), Len(strPrefix) + 1))
idVal = arr2(x, 2)
j = inArray(arr, district, 1) 'returns -1 if not found
If j >= 0 Then
arr(i + 1, j) = IIf(arr(i + 1, j) = "", idVal, arr(i + 1, j) & ";" & idVal)
Else
ReDim Preserve arr(1 To 5, 1 To UBound(arr, 2) + 1)
arr(1, UBound(arr, 2)) = district
arr(i + 1, UBound(arr, 2)) = idVal
End If
Next x
Set outputRange = Range("E1")
outputRange.Resize(UBound(arr, 2), UBound(arr, 1)).Value = Application.Transpose(arr)
outputRange.Sort Key1:=Range("E1"), Header:=xlYes, Order1:=xlAscending
Application.ScreenUpdating = True
End Sub
Public Function inArray(arr As Variant, k As String, Optional rowNum As Long, Optional colNum As Long) As Long
Dim i As Long, j As Long
inArray = -1
If rowNum Then
For i = LBound(arr, 2) To UBound(arr, 2)
If arr(rowNum, i) = k Then
inArray = i
Exit Function
End If
Next i
Else
For i = LBound(arr, 1) To UBound(arr, 1)
If arr(i, colNum) = k Then
inArray = i
Exit Function
End If
Next i
End If
End Function
by the way, i've found another solution, usinf both dictionary and 3-dimension array.
Sub test()
Dim Blg As New Scripting.Dictionary
Dim Sgm As New Scripting.Dictionary
Dim Siciller() As String
ReDim Siciller(0 To 23, 0 To 3, 0 To 5)
Set alanBolge = range(range("a2"), range("a2").End(xlDown))
Set alanSegment = range(range("c2"), range("c2").End(xlDown))
i = 0
For Each d In alanBolge
If Not Blg.Exists(d.Value) Then
Blg.Add Key:=d.Value, item:=i
i = i + 1
End If
Next d
k = 0
For Each d In alanSegment
If Not Sgm.Exists(d.Value) Then
Sgm.Add Key:=d.Value, item:=k
k = k + 1
End If
Next d
'data reading
For Each d In alanBolge
Siciller(Blg(d.Value), Sgm(d.Offset(0, 2).Value), dolusay(Siciller, Blg(d.Value), Sgm(d.Offset(0, 2).Value)) + 1) = d.Offset(0, 1).Value
Next d
'output
For x = 1 To 4
For y = 1 To 24
Set h = Cells(1 + y, 5 + x)
h.Select
h.Value = sonucgetir(Siciller, Blg(h.Offset(0, -x).Value), Sgm(h.Offset(-y, 0).Value))
Next y
Next x
End Sub
Public Function dolusay(ByVal data As Variant, ByVal i1 As Integer, ByVal i2 As Integer) As Integer
Dim count As Integer
count = 0
For j = 0 To UBound(data, 3) - 1
If Len(data(i1, i2, j)) > 0 Then
count = count + 1
End If
Next
dolusay = count
End Function
Public Function sonucgetir(ByVal data As Variant, ByVal i1 As Integer, ByVal i2 As Integer) As String
sonucgetir = ""
For i = 0 To UBound(data, 3)
If Len(data(i1, i2, i)) > 0 Then
x = data(i1, i2, i) & ";" & x
sonucgetir = Left(x, Len(x) - 1)
End If
Next i
End Function
I've a worksheet named "GetData". In this worksheet are more columns.
A(Names)|B... |C(Center)
++++++++|+++++++|+++++++++
Alpha | |100-Base
Beta | |110-2nd
Charly | |100-Base
Now I want sort them into another worksheet named "Overview" like this:
A(Grouped)
++++++++++
100-Base
Alpha
Charly
110-2nd
Beta
I think I need an array, but I don't know how to build this. I tried this for beginning:
Sub unique4()
Dim arr As New Collection, a
Dim aFirstArray() As Variant
Dim i As Long
Dim LastRow As Long
LastRow = Worksheets("GetData").Cells(Worksheets("GetData").Rows.Count, "C").End(xlUp).Row
aFirstArray() = Worksheets("GetData").Range("C2:C" & LastRow).Value
On Error Resume Next
For Each a In aFirstArray
arr.Add a, a
Next
For i = 1 To arr.Count
Cells(i, 1) = arr(i)
Next
End Sub
Here is one without arrays,
Sub unique4()
Dim i As Long
Dim lastrow As Long
Dim j As Long
Dim tws As Worksheet
Set tws = Sheets("Sheet2")'Change to desired sheet output name.
j = 1
With Sheets("GetData")
lastrow = .Cells(.Rows.Count, "C").End(xlUp).Row
For i = 1 To lastrow
If i <> 1 Then
If .Cells(i, 3) <> .Cells(i - 1, 3) Then
tws.Cells(j, 1) = .Cells(i, 3)
j = j + 1
tws.Cells(j, 1) = .Cells(i, 1)
j = j + 1
Else
tws.Cells(j, 1) = .Cells(i, 1)
j = j + 1
End If
Else
tws.Cells(j, 1) = .Cells(i, 3)
j = j + 1
tws.Cells(j, 1) = .Cells(i, 1)
j = j + 1
End If
Next
End With
End Sub
One Caveat, you will need to sort the data on column C to make work.
this should solve your issue with just an Excel formula. If you want a vba solution, that is of course possible too.
In your new sheet, in column A Setup it like:
Column A
1
1
2
2
3
3
You can get this format by entering the following in Cell A3 and pull it down as far as you need (set Cell A1, A2 with a value of 1).
=A1+1
In Column B you are going to enter an Indirect Formula. In cell B1, put this:
=INDIRECT("Sheet1!A"&A1)
In Cell B2, put this:
=INDIRECT("Sheet1!C"&A2)
Column A will keep track of which row to pull from, then the indirect formula will dynamically build the formula to get the value. Hope it helps!
Without sorting any data or something like that:
Sub test()
Dim LastRow As Long, i As Long, j As Long, k As Long, chkB As Boolean
Dim wsGet As Worksheet, wsPut As Worksheet
Set wsGet = ThisWorkbook.Worksheets(1)
Set wsPut = ThisWorkbook.Worksheets(2)
Const FirstRow As Long = 3
LastRow = wsGet.Range("C" & wsGet.Rows.Count).End(xlUp).Row
For i = FirstRow To LastRow
chkB = True
For j = FirstRow To i - 1
If wsGet.Cells(i, 3) = wsGet.Cells(j, 3) Then chkB = False: Exit For
Next
If chkB Then
k = k + 1
wsPut.Cells(k, 1) = wsGet.Cells(i, 3)
For j = i To LastRow
If wsGet.Cells(j, 3) = wsGet.Cells(i, 3) Then
k = k + 1
wsPut.Cells(k, 1) = wsGet.Cells(j, 1)
End If
Next
End If
Next
End Sub