मेरे पास एक दस्तावेज़ में एक कैलेंडर बार है जिसमें छवि के समान लेआउट है। कैलेंडर को पावर पिवट से कॉपी किया गया है, लेकिन मैं सूत्रों का उपयोग करके तिमाही, छमाही और वर्ष की कोशिकाओं की गणना करना चाहता हूं। मैं VBA का उपयोग करके ये सूत्र बनाना चाहता हूं। क्या ऐसा करने का कोई चतुर तरीका है?
कैलेंडर किसी भी महीने और वर्ष पर शुरू और समाप्त हो सकता है। क्वार्टर, आधा वर्ष और वर्ष हमेशा पूर्ण नहीं होते हैं, जिसका अर्थ है कि पूर्ण 3, 6 या 12 महीने हमेशा कैलेंडर में शामिल नहीं होते हैं।
मेरा सबसे अच्छा विचार तीन बार सभी स्तंभों पर लूप करना है। पहली बार, एक SUM सूत्र महीने के आधार पर एक साल के स्तंभ पर उतरने और फिर उस स्तंभ पर सूत्र लिखने तक। अगली बार, आधे साल के कॉलम के लिए एक ही कर रहा है। तीसरी बार, क्वार्टर कॉलम के लिए एक ही कर। लेकिन ऐसा लगता है कि यह कुछ सरल करने के लिए बहुत जटिल है।
0
30 नवम्बर 2015, 11:59
3 जवाब
सबसे बढ़िया उत्तर
आपको केवल एक बार लूप चलाने की आवश्यकता है, जैसा कि नीचे दिए गए कोड में है। मैंने उन कार्यों और चर पर अनुमान लगाया है जिन्हें आपने कोड में शामिल नहीं किया है इसलिए यहां पूरा मॉड्यूल है:
Option Explicit
Private Enum CellType
Unknown
Month
Quarter
Half
Year
End Enum
Private Const YEAR_ROW As Long = 1
Private Const HALF_ROW As Long = 2
Private Const QUARTER_ROW As Long = 3
Private Const MONTH_ROW As Long = 4
Private Const FIRST_VALUE_ROW As Long = 5
Private mWS As Worksheet
Private mRowCount As Long
Sub RunMe()
Dim ws As Worksheet
Dim lastCol As Long
Dim c As Long
Dim quarterRange As Range
Dim halfRange As Range
Dim yearRange As Range
Set mWS = ThisWorkbook.Worksheets("Sheet1") '~~> amend as necessary
mRowCount = mWS.Cells.Find(What:="*", _
After:=mWS.Cells(1), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row - FIRST_VALUE_ROW
lastCol = mWS.Cells(YEAR_ROW, mWS.Columns.Count).End(xlToLeft).Column
For c = 1 To lastCol
Select Case GetCellType(c)
Case CellType.Month
Set quarterRange = Unionised(quarterRange, c)
Case CellType.Quarter
Set halfRange = Unionised(halfRange, c)
Set quarterRange = FilledAndCleared(quarterRange, c)
Case CellType.Half
Set yearRange = Unionised(yearRange, c)
Set halfRange = FilledAndCleared(halfRange, c)
Case CellType.Year
Set yearRange = FilledAndCleared(yearRange, c)
End Select
Next
End Sub
Private Function GetCellType(c As Long) As CellType
Dim content As String
If Len(CStr(mWS.Cells(MONTH_ROW, c).Value2)) > 0 Then GetCellType = CellType.Month: Exit Function
If InStr(CStr(mWS.Cells(QUARTER_ROW, c).Value2), "Total") > 0 Then GetCellType = CellType.Quarter: Exit Function
If InStr(CStr(mWS.Cells(HALF_ROW, c).Value2), "Total") > 0 Then GetCellType = CellType.Half: Exit Function
If InStr(CStr(mWS.Cells(YEAR_ROW, c).Value2), "Total") > 0 Then GetCellType = CellType.Year: Exit Function
GetCellType = CellType.Unknown
End Function
Private Function Unionised(oldRng As Range, c As Long) As Range
If oldRng Is Nothing Then
Set Unionised = mWS.Cells(FIRST_VALUE_ROW, c)
Else
Set Unionised = Union(oldRng, mWS.Cells(FIRST_VALUE_ROW, c))
End If
End Function
Private Function FilledAndCleared(rng As Range, c As Long) As Range
Dim i As Long
For i = 0 To mRowCount
rng.Worksheet.Cells(FIRST_VALUE_ROW + i, c).Formula = "=SUM(" & rng.Offset(i).Address(False, False) & ")"
Next
Set FilledAndCleared = Nothing
End Function
1
1 पद 2015, 13:53
इस तरह मैंने इसे हल किया। मैं काफी सरल समाधान का स्वागत करता हूं।
'Year
sFormula = ""
For c = 6 To LastColumn(wksTarget)
If wksTarget.Cells(lMonthsRow, c) <> "" Then
sFormula = sFormula & "+" & wksTarget.Cells(lFirstItemRow, c).Address(RowAbsolute:=False, ColumnAbsolute:=False)
End If
If wksTarget.Cells(lMonthsRow, c) = "" And InStr(1, wksTarget.Cells(lYearsRow, c), "Total") Then
wksTarget.Range(wksTarget.Cells(lFirstItemRow, c), wksTarget.Cells(LastRow(wksTarget), c)) = "=" & sFormula
Call FormatAsTotal(wksTarget.Range(wksTarget.Cells(lFirstItemRow, c), wksTarget.Cells(LastRow(wksTarget), c)))
sFormula = ""
End If
Next
'Half year
sFormula = ""
For c = 6 To LastColumn(wksTarget)
If wksTarget.Cells(lMonthsRow, c) <> "" Then
sFormula = sFormula & "+" & wksTarget.Cells(lFirstItemRow, c).Address(RowAbsolute:=False, ColumnAbsolute:=False)
End If
If wksTarget.Cells(lMonthsRow, c) = "" And InStr(1, wksTarget.Cells(lHalfYearsRow, c), "Total") Then
wksTarget.Range(wksTarget.Cells(lFirstItemRow, c), wksTarget.Cells(LastRow(wksTarget), c)) = "=" & sFormula
Call FormatAsSubtotal(wksTarget.Range(wksTarget.Cells(lFirstItemRow, c), wksTarget.Cells(LastRow(wksTarget), c)))
sFormula = ""
End If
Next
'Quarter
sFormula = ""
For c = 6 To LastColumn(wksTarget)
If wksTarget.Cells(lMonthsRow, c) <> "" Then
sFormula = sFormula & "+" & wksTarget.Cells(lFirstItemRow, c).Address(RowAbsolute:=False, ColumnAbsolute:=False)
End If
If wksTarget.Cells(lMonthsRow, c) = "" And InStr(1, wksTarget.Cells(lQuartersRow, c), "Total") Then
wksTarget.Range(wksTarget.Cells(lFirstItemRow, c), wksTarget.Cells(LastRow(wksTarget), c)) = "=" & sFormula
Call FormatAsSubtotal(wksTarget.Range(wksTarget.Cells(lFirstItemRow, c), wksTarget.Cells(LastRow(wksTarget), c)))
sFormula = ""
End If
Next
0
30 नवम्बर 2015, 09:18
मेरा उत्तर काम करेगा अगर महीने और रकम नीचे की छवि के अनुसार निर्धारित की गई है (जो मुझे आपकी छवि से मिली है)।
Sub SomeSub()
Dim r As Long
Dim LastRow As Long
With ActiveSheet.UsedRange
'Getting the last Row of the used range
LastRow = .Rows(.Rows.Count).Row - 1
End With
'Loop for the rows of data
For r = 5 To LastRow
'Quarter Calculation
'Quarter 1
Range("D" & r).Value = Application.WorksheetFunction.Sum(Range("A" & r), Range("B" & r), Range("C" & r))
'Quarter 2
Range("H" & r).Value = Application.WorksheetFunction.Sum(Range("E" & r), Range("F" & r), Range("G" & r))
'Quarter 3
Range("Q" & r).Value = Application.WorksheetFunction.Sum(Range("J" & r), Range("K" & r), Range("K" & r))
'Quarter 4
Range("M" & r).Value = Application.WorksheetFunction.Sum(Range("N" & r), Range("O" & r), Range("P" & r))
'Bi Annual Calculation
'First 6 Months
Range("I" & r).Value = Application.WorksheetFunction.Sum(Range("A" & r), Range("B" & r), Range("C" & r), _
Range("E" & r), Range("F" & r), Range("G" & r))
'Second 6 Months
Range("R" & r).Value = Application.WorksheetFunction.Sum(Range("J" & r), Range("K" & r), Range("K" & r), _
Range("N" & r), Range("O" & r), Range("P" & r))
'Year Calculation
Range("S" & r).Value = Application.WorksheetFunction.Sum(Range("A" & r), Range("B" & r), Range("C" & r), _
Range("E" & r), Range("F" & r), Range("G" & r), _
Range("J" & r), Range("K" & r), Range("K" & r), _
Range("N" & r), Range("O" & r), Range("P" & r))
Next
End Sub
संपादित करें
ओपी टिप्पणी को ध्यान में रखते हुए कि क्वार्टर हमेशा 3 महीने नहीं हो सकता है, पहले क्वार्टर रेंज निर्धारित करने की आवश्यकता है।
नीचे नई स्क्रिप्ट देखें:
Sub SomeOtherSub()
Dim YrStart As Long, YrEnd As Long
Dim H1Start As Long, H1End As Long
Dim H2Start As Long, H2End As Long
Dim Q1Start As Long, Q1End As Long, Q1T As Long
Dim Q2Start As Long, Q2End As Long, Q2T As Long
Dim Q3Start As Long, Q3End As Long, Q3T As Long
Dim Q4Start As Long, Q4End As Long, Q4T As Long
Dim LastRow As Long
Dim col As Long
With ActiveSheet.UsedRange
'Getting the last Colunm of the used range
LastColumn = .Columns(.Columns.Count).Column
End With
'InStr() = 0 means that the text is not included in the string
'InStr() > 0 means that the text is included in the string
'Getting the Ranges for each Quarter
For col = 1 To LastColumn
aa = Cells(3, col)
If InStr(aa, "Q1") > 0 And InStr(aa, "Total") = 0 Then Q1Start = col
If InStr(aa, "Q1") > 0 And InStr(aa, "Total") > 0 Then
Q1End = col - 1 ' -1 for the end of the data for the quarter
Q1T = col
End If
If InStr(aa, "Q2") > 0 And InStr(aa, "Total") = 0 Then Q2Start = col
If InStr(aa, "Q2") > 0 And InStr(aa, "Total") > 0 Then
Q2End = col ' -1 for the end of the data for the quarter
Q2T = col
End If
If InStr(aa, "Q3") > 0 And InStr(aa, "Total") = 0 Then Q3Start = col
If InStr(aa, "Q3") > 0 And InStr(aa, "Total") > 0 Then
Q3End = col - 1 ' -1 for the end of the data for the quarter
Q3T = col
End If
If InStr(aa, "Q4") > 0 And InStr(aa, "Total") = 0 Then Q4Start = col
If InStr(aa, "Q4") > 0 And InStr(aa, "Total") > 0 Then
Q4End = col - 1 ' -1 for the end of the data for the quarter
Q4T = col
End If
Next
'Getting the Ranges for each Bi Annual
For col = 1 To LastColumn
aa = Cells(2, col)
If InStr(aa, "H1") > 0 And InStr(aa, "Total") = 0 Then H1Start = col
If InStr(aa, "H1") > 0 And InStr(aa, "Total") > 0 Then H1T = col
If InStr(aa, "H2") > 0 And InStr(aa, "Total") = 0 Then H2Start = col
If InStr(aa, "H2") > 0 And InStr(aa, "Total") > 0 Then H2T = col
Next
'Getting the Ranges for the year
For col = 1 To LastColumn
aa = Cells(1, col)
If Len(aa) > 0 And InStr(aa, "Total") = 0 Then YrStart = col
If Len(aa) > 0 And InStr(aa, "Total") > 0 Then YrT = col
Next
With ActiveSheet.UsedRange
'Getting the last Row of the used range
LastRow = .Rows(.Rows.Count).Row - 1
End With
'Loop for the rows of data
For r = 5 To LastRow
'Quarter Calculation
'Quarter 1
Cells(r, Q1T).Value = Application.WorksheetFunction.Sum(Range(Cells(r, Q1Start), Cells(r, Q1End)))
'Quarter 2
Cells(r, Q2T).Value = Application.WorksheetFunction.Sum(Range(Cells(r, Q2Start), Cells(r, Q2End)))
'Quarter 3
Cells(r, Q3T).Value = Application.WorksheetFunction.Sum(Range(Cells(r, Q3Start), Cells(r, Q3End)))
'Quarter 4
Cells(r, Q4T).Value = Application.WorksheetFunction.Sum(Range(Cells(r, Q4Start), Cells(r, Q4End)))
'Bi Annual Calculation
'First 6 Months
Cells(r, H1T).Value = Application.WorksheetFunction.Sum(Cells(r, Q1T), Cells(r, Q2T))
'Second 6 Months
Cells(r, H2T).Value = Application.WorksheetFunction.Sum(Cells(r, Q3T), Cells(r, Q4T))
'Year Calculation
Cells(r, YrT).Value = Application.WorksheetFunction.Sum(Cells(r, H1T), Cells(r, H2T))
Next
End Sub
0
30 नवम्बर 2015, 13:40