I'm trying to write a program that averages daily values into monthly values. The difficulty I found was that each month have different days of the month so I figured I had to change the steps in my loop. My program runs fine but the logic to the correct steps are a bit off.
lastrow2 = Range(Sheets("Daily").Cells(5, 3), Sheets("Daily").Cells(5, 3).End(xlDown)).Count
lastcol2 = Range(Sheets("Daily").Cells(5, 3), Sheets("Daily").Cells(5, 3).End(xlToRight)).Count
irow2 = 5
cnt = 5
Set wb = ActiveWorkbook
For j2 = 3 To lastcol1 + 3 'number of columns in the dataset
nextmo:
If Sheets("Daily").Cells(i2, 2) = 1 Or Sheets("Daily").Cells(i2, 2) = 60 Or Sheets("Daily").Cells(i2, 2) = 121 Or Sheets("Daily").Cells(i2, 2) = 182 Or Sheets("Daily").Cells(i2, 2) = 213 Or Sheets("Daily").Cells(i2, 2) = 274 Or Sheets("Daily").Cells(i2, 2) = 335 Then
daysofthemo = 31
ElseIf Sheets("Daily").Cells(i2, 2) = 91 Or Sheets("Daily").Cells(i2, 2) = 152 Or Sheets("Daily").Cells(i2, 2) = 244 Or Sheets("Daily").Cells(i2, 2) = 305 Then
daysofthemo = 30
ElseIf Sheets("Daily").Cells(i2, 2) = 32 Then
daysofthemo = 28
End If
For i2 = cnt To lastrow1 + 5 Step daysofthemo 'number of rows in the dataset
'Will now take the average of one month and paste onto worksheet called "monthly"
Set myRange2 = Range(wb.Worksheets("Daily").Cells(i2, j2), wb.Worksheets("Daily").Cells(i2 + daysofthemo - 1, j2))
If Application.WorksheetFunction.Count(myRange2) > 0 Then
wb.Worksheets("Monthly").Cells(irow2, j2).Value = Application.WorksheetFunction.Average(myRange2)
End If
irow2 = irow2 + 1
cnt = i2 + daysofthemo
goto nextmo
Next i2
Next j2
I have msgbox before and after the if statement.
The output should be:
274, 31, 305, 30, 335, 31, 1, 31, and so on.
But right now the output is: 274, 31, 305, 30, 336, 30, 2, 33, and so on.
Just thought of this new code, tested but still not right.
intDaysInMonth=DateDiff("d", DateSerial(Year(dtDate), Month(dtDate), 1), WorksheetFunction.EoMonth(dtDate, 0)) + 1
Related
I have a column of numbers and 11 intervals. I wanted to place each number in the interval that it belongs to, and also to determine if the number is close to the upper bound or lower bound.
For example: If the first number is 210, and it should be in my interval 180 to 365, and it is close to 180, so return "Lower Bound".
Here is my code, it worked however, too slow! I have only 5197 numbers, but it takes about 202 seconds to run it, more than 3 minutes! I wish to seek your help: where my program is inefficient, and how to increase the efficiency?
If I have even more numbers, or more criteria to add, the program must be even slower :(
Thank you so much!!
Sub test()
bgn = Timer
Application.ScreenUpdating = False
Dim T(1 To 12) As Integer 'My intervals
T(1) = 1
T(2) = 7
T(3) = 14
T(4) = 30
T(5) = 60
T(6) = 90
T(7) = 180
T(8) = 365
T(9) = 730
T(10) = 1095
T(11) = 1460
T(12) = 1825
For p = 4 To 5200 'My first number starts at row 4, so total 5197 numbers up to row 5200
For q = 1 To 11
'My column of numbers are in column G
If Range("G" & p) > T(q) And Range("G" & p) <= T(q + 1) Then
Range("H" & p) = T(q) 'Lower bound number
Range("I" & p) = T(q + 1) 'Upper bound number
'Determine closer to upper bound or lower bound
If Abs(Range("G" & p) - T(q)) >= Abs(Range("G" & p) - T(q + 1)) Then
Range("J" & p) = "Upper Bound"
Else
Range("J" & p) = "Lower Bound"
End If
Exit For
End If
Next q
Next p
MsgBox Timer - bgn
End Sub
Here's an example approach using Scott's suggestion.
On my PC this runs in a fraction of a second.
Sub test()
Dim bgn, p, q, arrIn, arrOut(), v
Dim rngInput As Range
bgn = Timer
Application.ScreenUpdating = False
Dim T(1 To 12) As Integer 'My intervals
T(1) = 1
T(2) = 7
T(3) = 14
T(4) = 30
T(5) = 60
T(6) = 90
T(7) = 180
T(8) = 365
T(9) = 730
T(10) = 1095
T(11) = 1460
T(12) = 1825
Set rngInput = Range("G4:G5200")
arrIn = rngInput.Value 'get all inputs in an array
ReDim arrOut(1 To UBound(arrIn, 1), 1 To 3) 'size an array to take the outputs
For p = 1 To UBound(arrIn, 1) 'My first number starts at row 4, so total 5197 numbers up to row 5200
v = arrIn(p, 1)
For q = 1 To 11
If v > T(q) And v <= T(q + 1) Then
'populate the output array
arrOut(p, 1) = T(q) 'Lower bound number
arrOut(p, 2) = T(q + 1) 'Upper bound number
arrOut(p, 3) = IIf(Abs(v - T(q)) >= Abs(v - T(q + 1)), "Upper Bound", "Lower bound")
Exit For
End If
Next q
Next p
rngInput.Offset(0, 1).Resize(, 3).Value = arrOut '<< place the outputs on the sheet
Debug.Print Timer - bgn
End Sub
This is an addition question of my previous post. I was not able to find a way to figure it out for hours nor also to find an idea from online search.
Suppose I have the following data (the actual data can be thousands or millions) in Excel sheet (Table 1):
Name Entry No. ID Expense 1 Expense 2
A 1 A1 14 5
B 2 B4 12 7
B 2 B5 20 8
C 3 C0 19 7
D 4 - 0 0
A 1 A1 11 6
A 1 A2 20 5
E 5 - 0 0
F 6 - 0 0
C 3 C0 15 5
B 2 B5 20 4
B 2 B5 16 3
B 2 B5 12 7
B 2 B6 18 8
A 1 A1 10 1
A 1 A1 14 7
A 1 A2 10 2
B 2 B3 13 7
B 2 B3 14 1
B 2 B3 11 4
The character (-) in column No. ID above can be also a number 0 or a blank cell.
I want to format the above data as follow (Table 2)
Name Entry No. ID Number of ID Sum of Expense 1 Sum of Expense 2
A 1 A1 2 49 19
A 1 A2 2 30 7
B 2 B3 4 38 12
B 2 B4 4 12 7
B 2 B5 4 68 22
B 2 B6 4 18 8
C 3 C0 1 34 12
D 4 - 0 0 0
E 5 - 0 0 0
F 6 - 0 0 0
Column Number of ID means A has 2 IDs (A1 and A2), B has 4 IDs (B1, B2, B3, and B4), C has 1 ID (C0), and D, E, and F have no ID. Column Sum of Expense 1 and 2 are the sum of all expense for each no. ID.
The best I can get by using Pivot Table is like this
How does one perform a task like Table 2 in MS Excel? If possible a VBA script of it.
This code after modifications works when running it from the same Workbook (doesn't matter which Worksheet).
Added an array to dynamic add number Sum of Expense types.
This code covers the logic needed to convert you table's data just like you wanted.
Sub OrganizeTable()
Dim TableArray() As Variant
Dim i, j, k, i_tmp, LastRow As Long
Dim Sum_Count As Integer
Dim SheetData, SheetResult As Excel.Worksheet
Dim StringTemp As String
Dim LongMin, LongMax As Long
Dim SumExpense() As Long
Dim Number_of_ID As Long
Dim Number_of_Expense_Type As Integer
' Number_of_Expense_Type = number of expense type you have in your
Number_of_Expense_Type = InputBox("Enter number of expense type ", "Expense Type counter")
Set SheetData = ActiveWorkbook.Worksheets("Sheet1")
LastRow = SheetData.Cells(SheetData.Rows.Count, "A").End(xlUp).row
Set SheetResult = ActiveWorkbook.Worksheets("Sheet2")
Erase TableArray
ReDim TableArray(1 To LastRow - 1, 1 To 3 + Number_of_Expense_Type) ' create array with exact number of Project names
ReDim SumExpense(1 To Number_of_Expense_Type)
i = 2
' insert all table's data into multi-dimensional array (easier and faster to manipulate later)
While SheetData.Cells(i, 1) <> ""
For j = 1 To 3 + Number_of_Expense_Type
TableArray(i - 1, j) = SheetData.Cells(i, j)
Next
i = i + 1
Wend
LongMin = LBound(TableArray())
LongMax = UBound(TableArray())
' this loop is for sorting the array according to Name, and then No. ID
For i = LongMin To LongMax - 1
For j = i + 1 To LongMax
' 1st rule: check for Name Value in Column A
If TableArray(i, 1) > TableArray(j, 1) Then
For k = 1 To 3 + Number_of_Expense_Type
StringTemp = TableArray(i, k)
TableArray(i, k) = TableArray(j, k)
TableArray(j, k) = StringTemp
Next
End If
' 2nd rule: check for No. ID in Column c
If TableArray(i, 1) = TableArray(j, 1) And TableArray(i, 3) > TableArray(j, 3) Then
For k = 1 To 3 + Number_of_Expense_Type
StringTemp = TableArray(i, k)
TableArray(i, k) = TableArray(j, k)
TableArray(j, k) = StringTemp
Next
End If
Next
Next
i = 1
j = 2 ' this is the Row number where the sorted table will start
k = 1 ' this is the Column number where the sorted table will start
While i <= LongMax
SheetResult.Cells(j, k) = TableArray(i, 1)
SheetResult.Cells(j, k + 1) = TableArray(i, 2)
SheetResult.Cells(j, k + 2) = TableArray(i, 3)
For Sum_Count = 1 To Number_of_Expense_Type
SumExpense(Sum_Count) = TableArray(i, 4 + Sum_Count - 1)
Next
' this IF and WHILE loop are for accumulating the Sum Expense 1 and Sum Expense 2 for the same ID type
If i + 1 <= LongMax Then
While TableArray(i, 3) = TableArray(i + 1, 3) And TableArray(i, 1) = TableArray(i + 1, 1)
For Sum_Count = 1 To Number_of_Expense_Type
SumExpense(Sum_Count) = SumExpense(Sum_Count) + Val(TableArray(i + 1, 4 + Sum_Count - 1))
Next
i = i + 1
Wend
End If
' this IF and WHILE loop are for counting how many Num of ID you have per Name
Number_of_ID = 0
If TableArray(i, 3) <> "-" Then
Number_of_ID = 1
For i_tmp = 1 To LongMax - 1
While Cells(j, k) = TableArray(i_tmp + 1, 1) And TableArray(i_tmp, 1) = TableArray(i_tmp + 1, 1) And TableArray(i_tmp, 3) <> TableArray(i_tmp + 1, 3)
Number_of_ID = Number_of_ID + 1
i_tmp = i_tmp + 1
Wend
Next
Else
Number_of_ID = 0
End If
SheetResult.Cells(j, k + 3) = Number_of_ID
For Sum_Count = 1 To Number_of_Expense_Type
SheetResult.Cells(j, k + 4 + Sum_Count - 1) = SumExpense(Sum_Count)
SumExpense(Sum_Count) = 0
Next
Number_of_ID = 0
j = j + 1
i = i + 1
Wend
' writing down the headers for you table
SheetResult.Cells(1, k) = "Name"
SheetResult.Cells(1, k + 1) = "Entry"
SheetResult.Cells(1, k + 2) = "No. ID"
SheetResult.Cells(1, k + 3) = "Number of ID"
For Sum_Count = 1 To Number_of_Expense_Type
SheetResult.Cells(1, k + 4 + Sum_Count - 1) = "Sum of Expense " & Sum_Count
Next
Set SheetData = Nothing
Set SheetResult = Nothing
End Sub
Below code might help:
Assumptions:
1. Your data is in ActiveSheet
2. Result will be displayed in the Sheet2
Sub Demo()
Dim dict1 As Object, dict2 As Object
Dim c1 As Variant, c2 As Variant
Dim i As Long, lastRow As Long, targetRow As Long, count As Long
Dim targetWS As Worksheet
Set targetWS = ThisWorkbook.Sheets("Sheet2")
Set dict1 = CreateObject("Scripting.Dictionary")
Set dict2 = CreateObject("Scripting.Dictionary")
'get last row with data
lastRow = Cells(Rows.count, "A").End(xlUp).Row
'assign unique values in Column A (Name) to dict1
c1 = Range("A2:A" & lastRow)
For i = 1 To UBound(c1, 1)
dict1(c1(i, 1)) = 1
Next i
'assign unique values in Column C (No. Id) to dict2
c2 = Range("C2:C" & lastRow)
For i = 1 To UBound(c2, 1)
dict2(c2(i, 1)) = 1
Next i
'write headers in Sheet2
targetWS.Cells(1, 1) = "Name"
targetWS.Cells(1, 2) = "Entry"
targetWS.Cells(1, 3) = "No. Id"
targetWS.Cells(1, 4) = "Number of ID"
targetWS.Cells(1, 5) = "Sum of Expense 1"
targetWS.Cells(1, 6) = "Sum of Expense 2"
'fill data in table
targetRow = 2 '-->targetRow will keep the counter for new row in Sheeet2
'loop through unique values of Name through dict1
For Each k1 In dict1.Keys
count = 0
'loop through unique No. ID through dict2 to match values in dict1 and dict2
For Each k2 In dict2.Keys
If k2 Like k1 & "*" Then '-->match values of dict1 and dict2
count = count + 1
'fill data in table if match found
targetWS.Cells(targetRow, 1) = k1
targetWS.Cells(targetRow, 3) = k2
targetWS.Cells(targetRow, 4) = dict2(k2)
targetWS.Cells(targetRow, 5) = Application.WorksheetFunction.SumIf(Range("C2:C" & lastRow), k2, Range("D2:D" & lastRow))
targetWS.Cells(targetRow, 6) = Application.WorksheetFunction.SumIf(Range("C2:C" & lastRow), k2, Range("E2:E" & lastRow))
targetRow = targetRow + 1
End If
Next k2
'fill data if no match found
If count = 0 Then
targetWS.Cells(targetRow, 1) = k1
targetWS.Cells(targetRow, 3) = "-"
targetWS.Cells(targetRow, 5) = 0
targetWS.Cells(targetRow, 6) = 0
targetRow = targetRow + 1
End If
Next k1
'get values for Entry and Number of ID
For i = 2 To targetWS.Cells(Rows.count, "A").End(xlUp).Row
targetWS.Cells(i, 2) = Range("A:A").Find(What:=targetWS.Cells(i, 1), LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=True).Offset(0, 1).Value
targetWS.Cells(i, 4) = Application.WorksheetFunction.CountIf(targetWS.Range("A1:A" & lastRow), targetWS.Cells(i, 1))
Next i
End Sub
Note: Above code will not display data in ascending order like A1-A2-B3-B4-B5-B6-C0 instead data will be displayed in the order of appearance like A1-A2-B4-B5-B6-B3-C0
See image for reference:
You can have VBA to copy the pivot table data and paste it as normal table.
I have a workbook (C:\DOORS.xlsx) with the following data:
A B C D
100 ... Type A Description Remarks
102 ... Type B Description Remarks
103 ... Type C Description Remarks
I need to create a loop that goes thru each row that outputs the data onto a different workbook (C:\QT.xlsx). It needs to be able to make sure the values for Door and Description cannot be more than 55 characters long. If they are more than 55 characters in length then it needs to move the remainder onto the next row without cutting a word in half. Also if Remarks is blank then this is where the description should go.
Output would look like this on QT.xlsx:
'Starting at cell D18
A B C D
18 Door: 100, 100, 103, 104, 105,
19 106, 107, 108, 110, 107
20 Type A
21 Remarks A 'Text Should Be Bold
22 This is a really long description
23 and needs to fit in this space by
24 being 55 characters long and does
25 cut a word in half.
26
27 Door: 102, 100, 103, 104,
28 Type B
29 Remarks B 'Text Should Be Bold
30 Description
31
32 Door: 103, 100, 103, 104,
33 Type C
34 Description 'This is a blank cell in DOORS.xlsx
35
I'm still learning VBA and I'm new to looping. Not sure where to start but any help is greatly appreciated. Thanks in advance.
EDIT This should work as you need it. However, it is a huge change, if there are questions, just write a comment. :)
Option Explicit
Sub GetTheData()
Dim MyWSSource As Worksheet
Dim MyWSTarget As Worksheet
Dim sArr As Variant
Dim i As Long, j As Long, k As Byte, iLines As Long
Application.ScreenUpdating = False 'will automatically set to true after the sub ends
Set MyWSSource = Workbooks.Open("C:\DOORS.xlsx").Sheets(1) 'set your source wb+sheet
Set MyWSTarget = Workbooks.Open("C:\QT.xlsx").Sheets(1) 'set your target wb+sheet
iLines = MyWSSource.Cells(Rows.Count, 1).End(xlUp).Row 'get the last line to be processed
j = 18 'set the first line to output
For i = 1 To iLines
For k = 1 To 4
If Len(MyWSSource.Cells(i, Array(1, 2, 4, 3)(k - 1)).Value) Then 'if cell is empty it will be skipped
If k = 1 Then
' ---------- new lines start ----------
MyWSTarget.Cells(j, 2).Value = Len(MyWSSource.Cells(i, 1).Value) - Len(Replace(MyWSSource.Cells(i, 1).Value, ",", "")) + 1 'new line for count in b
If Left(MyWSSource.Cells(i, 3).Value, 4) = "Pair" Then 'case sensitive
'If LCase(Left(MyWSSource.Cells(i, 3).Value, 4)) = "pair" Then 'not case sensitive
MyWSTarget.Cells(j, 3).Value = "PR"
Else
MyWSTarget.Cells(j, 3).Value = "EA"
End If
' ---------- new lines end ----------
sArr = CropText("Door: " & MyWSSource.Cells(i, 1).Value) 'sets the "Door: " for column A
Else
sArr = CropText(MyWSSource.Cells(i, Array(1, 2, 4, 3)(k - 1)).Value)
'the "Array(1, 2, 4, 3)(k - 1)" switches col C and D cus you want A->B->D->C
End If
If k = 3 Then MyWSTarget.Cells(j, 4).Font.Bold = True 'bolt Remark-line
MyWSTarget.Cells(j, 4).Value = sArr(0): j = j + 1 'input text and goto next line
While Len(sArr(1))
sArr = CropText(CStr(sArr(1)))
If k = 3 Then MyWSTarget.Cells(j, 4).Font.Bold = True 'bolt Remark-line
MyWSTarget.Cells(j, 4).Value = sArr(0): j = j + 1 'input text and goto next line
Wend
End If
Next
j = j + 1 'adds an empty line after each dataset
Next
MyWSSource.Parent.Close 0 'close your source (discard changes -> no changes made)
MyWSTarget.Parent.Close 1 'close your target (save changes)
End Sub
Public Function CropText(a As String) As Variant
Dim b As String, i As Long
If Len(a) > 55 Then
For i = 0 To 55
If Mid(a, 56 - i, 1) = " " Then
CropText = Array(Left(a, 55 - i), Mid(a, 57 - i))
Exit Function
End If
Next
CropText = Array(Left(a, 55), Mid(a, 56)) 'new line -> see *NOTE
Else
CropText = Array(a, "")
End If
End Function
CropText(string) will split the text into 2 parts (the first is shorter than 56 characters and the second will be all thats left) *NOTE: If the text string has more than 55 characters without a space, it will be cut at the 55th character!
How it looks for me: (without the column B/C change)
Input: (DOORS.xlsx)
Output: (QT.xlsx)
A B C D
18 10 EA Door: 100, 100, 103, 104, 105,
19 106, 107, 108, 110, 107
20 Type A
21 Remarks A 'Text Should Be Bold
22 This is a really long description
23 and needs to fit in this space by
24 being 55 characters long and does
25 cut a word in half.
26
27 4 PR Door: 102, 100, 103, 104
28 Type B
29 Remarks B 'Text Should Be Bold
30 PAIR Description
31
32 3 EA Door: 103, 100, 103, 104
33 Type C
34 Description 'This is a blank cell in DOORS.xlsx
35
This is far to advanced for me to figure out.
Here is an example of the worksheet layout:
Row# ColA ColB
23 7 Description
24 8 Description
25
26 For cases with
27 SpecialOptionDesc = Yes
28 9 Description
29
30 For cases with
31 SomeOptionDesc = Yes
32 and
33 AnotherOptionDesc = No
34 9 Description
35
36 10 Description
I'm need to consolidate the information in ColB when the them "For cases with" appears, with the cells below it. The information needs to end up on the row that has the identifying number in ColA. So in this case ColB Rows 26, 27, 28, will all be "copied" or whatever into ColB row 28. Likewise, ColB Rows 30 though 34 will all be on ColB row 34. The old rows (26, 27, 30, 31, 33) can be deleted mashed together or whatever. No data on those rows will be needed any longer.
I didn't actually compile this and try it Excel, but I think that it will get you 90% of the way there if not all the way. I am stepping away from the computer for a bit, but will do some testing when I get back.
Dim cellValue As String
Dim i As Integer
Dim j As Integer
Dim strResult As String
Const endRow As Integer = 500
For i = 1 To endRow
If LCase(ActiveSheet.Cells(i, 2).Value) = "for cases with" Then
j = 0
strResult = ""
While ActiveSheet.Cells(i + j, 1).Value = "" And i + j < endRow
strResult = strResult + " " + ActiveSheet.Cells(i + j, 2).Value
' delete stuff after using
ActiveSheet.Cells(i + j, 2).Value = ""
j = j + 1
Wend
ActiveSheet.Cells(i + j, 2) = strResult + " " + ActiveSheet.Cells(i + j, 2)
End If
Next i
I've created a particularly long vba macro to edit a large spreadsheet of data for me instead of doing it myself thousands of times. The code for the actual editing works fine, however, when I add in the first if statements and first while loop to make it loop through the whole spreadsheet, I get a runtime error 1004. I'm new to vba but I'm pretty sure there is an error in my logic rather than the code itself. I've marked which lines of code cause the error when added.
Sub RCFS()
Dim ProfCtr As String
Dim Year As String
Dim Amount As Currency
Dim Period As Long
Dim S2FreecellH As Long
Dim ProfCenCellH As Long
Dim FreeCellClone As Long
Dim Clone2 As Long
Dim Clone3 As Long
Dim y As Long ' placeholder 2
y = 1
S2FreecellH = 3
ProfCenCellH = 2
AmountH = 2
PeriodH = 2
YearH = 2
ProfCtr = Cells(ProfCenCellH, 4)
Year = Cells(YearH, 7)
Amount = Cells(AmountH, 8)
Period = Cells(PeriodH, 6)
'//////////////////////////////////////////////////////////////////////////////////
While IsEmpty(Cells(ProfCenCell, 4).Value) = False
Everything fine until this while loop (above) and if statement (below). The rest works fine without these 2 statements but I need it to loop through the whole spreadsheet.
If Cells(ProfCenCell, 4).Value = Worksheets("Sheet2").Cells(S2FreecellH, 1).Value Then
Worksheets("Sheet2").Cells(S2FreecellH, 1).Value = ProfCtr
Worksheets("Sheet2").Cells(S2FreecellH, 5).Value = ProfCtr
Worksheets("Sheet2").Cells(S2FreecellH, 9).Value = ProfCtr
FreeCellClone = S2FreecellH 'setting clones
Clone2 = S2FreecellH
Clone3 = S2FreecellH
For x = S2FreecellH + 1 To S2FreecellH + 12
Worksheets("Sheet2").Cells(x, 2).Value = y 'Creating 1 to 12 numbering in column 1
Worksheets("Sheet2").Cells(x, 6).Value = y 'Creating 1 to 12 numbering in column 2
Worksheets("Sheet2").Cells(x, 10).Value = y 'Creating 1 to 12 numbering in column 3
S2FreecellH = S2FreecellH + 1
y = y + 1
Next x
While Worksheets("Sheet2").Cells(FreeCellClone, 1).Value = Cells(YearH, 4).Value 'Loop to input all amounts
Worksheets("Sheet2").Cells(FreeCellClone + Period, (((Year Mod 11) * 4)) - 1).Value = Amount 'Calculation on post year to select correct column to post amount in
PeriodH = PeriodH + 1
AmountH = AmountH + 1
YearH = YearH + 1
Year = Cells(YearH, 7)
Amount = Cells(AmountH, 8)
Period = Cells(PeriodH, 6)
Wend
Worksheets("Sheet2").Cells(S2FreecellH + 1, 3) = WorksheetFunction.Sum(Worksheets("Sheet2").Range(Worksheets("Sheet2").Cells(FreeCellClone + 1, 3), Worksheets("Sheet2").Cells(S2FreecellH, 3)))
Worksheets("Sheet2").Cells(S2FreecellH + 1, 7) = WorksheetFunction.Sum(Worksheets("Sheet2").Range(Worksheets("Sheet2").Cells(FreeCellClone + 1, 7), Worksheets("Sheet2").Cells(S2FreecellH, 7))) 'Creating sums for all 3 columns
Worksheets("Sheet2").Cells(S2FreecellH + 1, 11) = WorksheetFunction.Sum(Worksheets("Sheet2").Range(Worksheets("Sheet2").Cells(FreeCellClone + 1, 11), Worksheets("Sheet2").Cells(S2FreecellH, 11)))
For Z = Clone2 + 1 To Clone2 + 12 'creating intitial percentage values
Worksheets("Sheet2").Cells(Z, 4).Value = Format((Worksheets("Sheet2").Cells(Z, 3) / Worksheets("Sheet2").Cells(S2FreecellH + 1, 3)) * 100, "%0.00")
Worksheets("Sheet2").Cells(Z, 8).Value = Format((Worksheets("Sheet2").Cells(Z, 7) / Worksheets("Sheet2").Cells(S2FreecellH + 1, 7)) * 100, "%0.00")
Worksheets("Sheet2").Cells(Z, 12).Value = Format((Worksheets("Sheet2").Cells(Z, 11) / Worksheets("Sheet2").Cells(S2FreecellH + 1, 11)) * 100, "%0.00")
Next
For q = Clone3 + 1 To Clone3 + 12 'creating final percentage values
Worksheets("Sheet2").Cells(q, 13).Value = Format(((Worksheets("Sheet2").Cells(q, 4) + Worksheets("Sheet2").Cells(q, 8) + Worksheets("Sheet2").Cells(q, 12)) / 3) * 100, "%0.00")
Next q
Worksheets("Sheet2").Cells(S2FreecellH + 1, 13) = WorksheetFunction.Sum(Worksheets("Sheet2").Range(Worksheets("Sheet2").Cells(FreeCellClone + 1, 13), Worksheets("Sheet2").Cells(S2FreecellH, 13)))
Else
ProfCenCell = ProfCenCell + 1
End If
'/////////////////////////////////////////////////////////////////////////////// Loop these Loops
S2FreecellH = S2FreecellH + 3
y = 1
Wend
End Sub
You never set a value for ProfCenCell, hence it has default value 0. Then, you use Cells(ProfCenCell, 4) which is in your case Cells(0, 4) and that 0 makes a problem.