मेरे पास एक दस्तावेज़ में एक कैलेंडर बार है जिसमें छवि के समान लेआउट है। कैलेंडर को पावर पिवट से कॉपी किया गया है, लेकिन मैं सूत्रों का उपयोग करके तिमाही, छमाही और वर्ष की कोशिकाओं की गणना करना चाहता हूं। मैं VBA का उपयोग करके ये सूत्र बनाना चाहता हूं। क्या ऐसा करने का कोई चतुर तरीका है?

कैलेंडर किसी भी महीने और वर्ष पर शुरू और समाप्त हो सकता है। क्वार्टर, आधा वर्ष और वर्ष हमेशा पूर्ण नहीं होते हैं, जिसका अर्थ है कि पूर्ण 3, 6 या 12 महीने हमेशा कैलेंडर में शामिल नहीं होते हैं।

enter image description here

मेरा सबसे अच्छा विचार तीन बार सभी स्तंभों पर लूप करना है। पहली बार, एक SUM सूत्र महीने के आधार पर एक साल के स्तंभ पर उतरने और फिर उस स्तंभ पर सूत्र लिखने तक। अगली बार, आधे साल के कॉलम के लिए एक ही कर रहा है। तीसरी बार, क्वार्टर कॉलम के लिए एक ही कर। लेकिन ऐसा लगता है कि यह कुछ सरल करने के लिए बहुत जटिल है।

0
user1283776 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
Ambie 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
user1283776 30 नवम्बर 2015, 09:18

मेरा उत्तर काम करेगा अगर महीने और रकम नीचे की छवि के अनुसार निर्धारित की गई है (जो मुझे आपकी छवि से मिली है)।

enter image description here

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
Jean-Pierre Oosthuizen 30 नवम्बर 2015, 13:40