Code description

**vio.coman** · 12-08-2014, 05:49 AM

Hi guys,

I’ve got a code below for which I‘d need a description. Unfortunately, my VBA skills are rather poor, therefore I kindly ask for your support.
I appreciate it very much, thank you all in advance!

Sub KoepfeAlle()

Dim I, j, k, ID_number, column_widths, manager_name, r_row, c_col
Application.ScreenUpdating = False
With Sheets("Aux")
    For I = 3 To .Range("AN" & Rows.count).End(xlUp).Row
        If InStr(1, ID_number, Split(.Range("Q" & I), " ")(0)) = 0 And Not .Range("Q" & I) = "n/a" Then
            ID_number = ID_number & "," & Split(.Range("Q" & I), " ")(0)
        End If
    Next
    ID_number = Split(Right(ID_number, Len(ID_number) - 1), ",")
End With
For I = LBound(ID_number) To UBound(ID_number)
    With Sheets.Add
        .Name = ID_number(I) & "_Koepfe Alle"
        .Columns(1).ColumnWidth = 3
        .Columns(2).ColumnWidth = 20
        .Columns(3).ColumnWidth = 22
        .Columns(4).ColumnWidth = 12
        .Columns(5).ColumnWidth = 20
        .Columns(6).ColumnWidth = 9
        .Range("B2") = "Team"
        .Range("C2") = "FK"
        .Range("D2") = "EmplID"
        .Range("E2") = "Name"
        .Range("F2") = "'01/14"
        ActiveWindow.DisplayGridlines = False
    End With
Next I
For I = 4 To Sheets("Vergütungsdaten_M").Range("K" & Rows.count).End(xlUp).Row
    If Not Sheets("Vergütungsdaten_M").Range("D" & I) = 41639 And Sheets("Vergütungsdaten_M").Range("CT" & I) = "aktiv" Then
    If Not Sheets("Vergütungsdaten_M").Range("CP" & I) = "n/a" And Not Sheets("Vergütungsdaten_M").Range("CO" & I) = "n/a" Then
        If Not Sheets("Vergütungsdaten_M").Range("K" & I) = "" And Not Sheets("Vergütungsdaten_M").Range("J" & I) = "" Then
            With Sheets(Split(WorksheetFunction.Index(Sheets("Aux").Range("Q:Q"), _
                WorksheetFunction.Match(Sheets("Vergütungsdaten_M").Range("K" & I), _
                    Sheets("Aux").Range("T:T"), 0)), " ")(0) & "_Koepfe Alle")
                manager_name = WorksheetFunction.Index(Sheets("Aux").Range("R:R"), _
                    WorksheetFunction.Match(Sheets("Vergütungsdaten_M").Range("K" & I), _
                    Sheets("Aux").Range("T:T"), 0))
                If Sheets("Vergütungsdaten_M").Range("D" & I) = 41670 Then '41639
                    If Not Sheets("Vergütungsdaten_M").Range("Q" & I) = 0 Then
                        .Range("B" & Rows.count).End(xlUp).Offset(1, 0) = Sheets("Vergütungsdaten_M").Range("CP" & I)
                        .Range("C" & Rows.count).End(xlUp).Offset(1, 0) = Sheets("Vergütungsdaten_M").Range("CO" & I)
                        .Range("D" & Rows.count).End(xlUp).Offset(1, 0) = Sheets("Vergütungsdaten_M").Range("F" & I)
                        .Range("E" & Rows.count).End(xlUp).Offset(1, 0) = Sheets("Vergütungsdaten_M").Range("J" & I)
                        .Range("F" & Rows.count).End(xlUp).Offset(1, 0) = Sheets("Vergütungsdaten_M").Range("Q" & I)
                    End If
                Else
                    If WorksheetFunction.CountIf(.Rows(2), Right("0" & Month(Sheets("Vergütungsdaten_M").Range("D" & I)) & "/" & Right(Year(Sheets("Vergütungsdaten_M").Range("D" & I)), 2), 5)) = 0 Then
                        .Cells(2, Columns.count).End(xlToLeft).Offset(0, 1).ColumnWidth = 9
                        .Cells(2, Columns.count).End(xlToLeft).Offset(0, 1) = "'" & Right("0" & Month(Sheets("Vergütungsdaten_M").Range("D" & I)) & "/" & Right(Year(Sheets("Vergütungsdaten_M").Range("D" & I)), 2), 5)
                        .Cells(2, Columns.count).End(xlToLeft).Offset(0, 1).ColumnWidth = 9
                        .Cells(2, Columns.count).End(xlToLeft).Offset(0, 1) = "Delta VM"
                        .Cells(2, Columns.count).End(xlToLeft).Offset(0, 1).ColumnWidth = 14.14
                        .Cells(2, Columns.count).End(xlToLeft).Offset(0, 1) = "Effekt"
                    End If
                    c_col = WorksheetFunction.Match(Right("0" & Month(Sheets("Vergütungsdaten_M").Range("D" & I)) & "/" & Right(Year(Sheets("Vergütungsdaten_M").Range("D" & I)), 2), 5), .Rows(2), 0)
                    r_row = Evaluate("=MAX(IF('" & .Name & "'!C1:C" & .Range("D" & Rows.count).End(xlUp).Row & "='Vergütungsdaten_M'!CO" & I & ",ROW(A1:A" & .Range("D" & Rows.count).End(xlUp).Row & "),0)*if('" & .Name & "'!B1:B" & .Range("D" & Rows.count).End(xlUp).Row & "='Vergütungsdaten_M'!CP" & I & ",1,0)*if('" & .Name & "'!D1:D" & .Range("D" & Rows.count).End(xlUp).Row & "='Vergütungsdaten_M'!F" & I & ",1,0))")
                     If r_row = 0 Then
                        .Range("B" & Rows.count).End(xlUp).Offset(1, 0) = Sheets("Vergütungsdaten_M").Range("CP" & I)
                        .Range("C" & Rows.count).End(xlUp).Offset(1, 0) = Sheets("Vergütungsdaten_M").Range("CO" & I)
                        .Range("D" & Rows.count).End(xlUp).Offset(1, 0) = Sheets("Vergütungsdaten_M").Range("F" & I)
                        .Range("E" & Rows.count).End(xlUp).Offset(1, 0) = Sheets("Vergütungsdaten_M").Range("J" & I)
                        r_row = Evaluate("=MAX(IF('" & .Name & "'!C1:C" & .Range("D" & Rows.count).End(xlUp).Row & "='Vergütungsdaten_M'!CO" & I & ",ROW(A1:A" & .Range("D" & Rows.count).End(xlUp).Row & "),0)*if('" & .Name & "'!B1:B" & .Range("D" & Rows.count).End(xlUp).Row & "='Vergütungsdaten_M'!CP" & I & ",1,0)*if('" & .Name & "'!D1:D" & .Range("D" & Rows.count).End(xlUp).Row & "='Vergütungsdaten_M'!F" & I & ",1,0))")
                    End If
                    .Cells(r_row, c_col) = Sheets("Vergütungsdaten_M").Range("Q" & I)
                    .Cells(r_row, c_col + 2) = Sheets("Vergütungsdaten_M").Range("BZ" & I)
                End If
            End With
        End If
    End If
    End If
Next I
For I = LBound(ID_number) To UBound(ID_number)
    With Sheets(ID_number(I) & "_Koepfe Alle")
        .Select
        .Sort.SortFields.Clear
        .Sort.SortFields.Add Key:=.Range("B3:B" & .Range("B3").End(xlDown).Row), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
            xlSortNormal
        .Sort.SortFields.Add Key:=.Range("C3:C" & .Range("C3").End(xlDown).Row), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
            xlSortNormal
        .Sort.SortFields.Add Key:=.Range("E3:E" & .Range("E3").End(xlDown).Row), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
            xlSortNormal
        .Sort.SetRange .Range("B3:" & .Cells(.Range("B2").End(xlDown).Row, .Range("B2").End(xlToRight).Column).Address)
        .Sort.Apply
        .Range("A3:A" & .Range("B" & Rows.count).End(xlUp).Row).Formula = "=IF(B3=B2,"""",B3)"
        .Range("B3:B" & .Range("B" & Rows.count).End(xlUp).Row).Value = Range("A3:A" & Range("B" & Rows.count).End(xlUp).Row).Value
        .Range("A3:A" & .Range("C" & Rows.count).End(xlUp).Row).Formula = "=IF(AND(B3="""",C3=C2),"""",C3)"
        .Range("C3:C" & .Range("C" & Rows.count).End(xlUp).Row).Value = Range("A3:A" & Range("C" & Rows.count).End(xlUp).Row).Value
        .Columns(1).Value = ""
        j = 3
        Do Until .Range("D" & j) = ""
            If Not .Range("B" & j) = "" Then
                .Rows(j).Insert
                .Range("B" & j) = .Range("B" & j + 1)
                .Range("B" & j + 1) = ""
            End If
            j = j + 1
        Loop
        j = 3
        Do Until .Range("D" & j) = "" And .Range("B" & j) = ""
            If Not .Range("C" & j) = "" Then
                .Rows(j).Insert
                .Range("C" & j) = .Range("C" & j + 1)
                .Range("C" & j + 1) = ""
            End If
            j = j + 1
        Loop
        .Columns(8).SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=RC[-1]-RC[-2]"
        For k = 9 To .Cells(2, Columns.count).End(xlToLeft).Column
            If Cells(2, k) = "Delta VM" Then
                .Columns(k).SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=RC[-1]-RC[-4]"
            End If
        Next k
        .Rows(1).Value = ""
        For j = 3 To .Range("E" & Rows.count).End(xlUp).Row
            If Not .Range("B" & j) = "" Then
                Cells(j, 6).FormulaR1C1 = "=SUMIF(R[1]C4:R[" & WorksheetFunction.Min(Cells(Rows.count, 4).End(xlUp).Row, .Cells(j, 2).End(xlDown).Row - j - 1) & "]C4,""<>""&"""",R[1]C:R[" & WorksheetFunction.Min(Cells(Rows.count, 4).End(xlUp).Row, .Cells(j, 2).End(xlDown).Row - j - 1) & "]C)"
                For k = 7 To .Cells(2, Columns.count).End(xlToLeft).Column Step 3
                    Cells(j, k).Resize(1, 2).FormulaR1C1 = "=SUMIF(R[1]C4:R[" & WorksheetFunction.Min(Cells(Rows.count, 4).End(xlUp).Row, .Cells(j, 2).End(xlDown).Row - j - 1) & "]C4,""<>""&"""",R[1]C:R[" & WorksheetFunction.Min(Cells(Rows.count, 4).End(xlUp).Row, .Cells(j, 2).End(xlDown).Row - j - 1) & "]C)"
                Next k
            ElseIf Not .Range("C" & j) = "" Then
                Cells(j, 6).FormulaR1C1 = "=SUMIF(R[1]C4:R[" & WorksheetFunction.Min(Cells(Rows.count, 4).End(xlUp).Row, .Cells(j, 3).End(xlDown).Row - j - 1) & "]C4,""<>""&"""",R[1]C:R[" & WorksheetFunction.Min(Cells(Rows.count, 4).End(xlUp).Row, .Cells(j, 3).End(xlDown).Row - j - 1) & "]C)"
                For k = 7 To .Cells(2, Columns.count).End(xlToLeft).Column Step 3
                    Cells(j, k).Resize(1, 2).FormulaR1C1 = "=SUMIF(R[1]C4:R[" & WorksheetFunction.Min(Cells(Rows.count, 4).End(xlUp).Row, .Cells(j, 3).End(xlDown).Row - j - 1) & "]C4,""<>""&"""",R[1]C:R[" & WorksheetFunction.Min(Cells(Rows.count, 4).End(xlUp).Row, .Cells(j, 3).End(xlDown).Row - j - 1) & "]C)"
                Next k
            End If
        Next j
        r_row = .Range("D" & Rows.count).End(xlUp).Offset(1, 0).Row
        .Range("B" & r_row) = "Summe"
        .Range("F" & r_row).Formula = "=SUMIF(B3:B" & r_row - 1 & ",""<>""&"""",F3:F" & r_row - 1 & ")"
        For j = 7 To Cells(2, Columns.count).End(xlToLeft).Column Step 3
            .Cells(r_row, j).Resize(1, 2).FormulaR1C1 = "=SUMIF(R3C2:R" & r_row - 1 & "C2,""<>""&"""",R3C[]:R" & r_row - 1 & "C[])"
        Next j
    .Cells.RowHeight = 12.75
    .Rows(2).RowHeight = 25.5
    End With
    With Sheets(ID_number(I) & "_Koepfe Alle").Range("B2:" & Sheets(ID_number(I) & "_Koepfe Alle").Cells(2, Columns.count).End(xlToLeft).Address)
        .Interior.ColorIndex = 23
        .Font.Bold = True
        .Font.ColorIndex = 2
        .VerticalAlignment = xlCenter
        .HorizontalAlignment = xlCenter
    End With
    With Intersect(Sheets(ID_number(I) & "_Koepfe Alle").UsedRange, Sheets(ID_number(I) & "_Koepfe Alle").Range("B2:" & Cells(Rows.count, Columns.count).Address))
        .Borders(xlInsideHorizontal).LineStyle = xlContinuous
        .Borders(xlInsideVertical).LineStyle = xlContinuous
        .BorderAround xlContinuous
    End With
    count = 4
    Do Until count = Rows.count
        With Sheets(ID_number(I) & "_Koepfe Alle").Range("C" & count & ":" & Sheets(ID_number(I) & "_Koepfe Alle").Cells(count, Columns.count).End(xlToLeft).Offset(0, 1).Address)
            .Interior.Pattern = xlSolid
            .Interior.PatternColorIndex = xlAutomatic
            .Interior.ThemeColor = xlThemeColorDark1
            .Interior.TintAndShade = -0.149998474074526
            .Interior.PatternTintAndShade = 0
            .Font.Bold = True
            .VerticalAlignment = xlCenter
            .HorizontalAlignment = xlCenter
        End With
        r_row = Sheets(ID_number(I) & "_Koepfe Alle").Range("C" & count).End(xlDown).Row
        Sheets(ID_number(I) & "_Koepfe Alle").Range("C" & count + 1 & ":C" & r_row - 1).Borders(xlInsideHorizontal).LineStyle = xlNone
         count = r_row
    Loop
    count = 3
    Do Until count = Rows.count
        With Sheets(ID_number(I) & "_Koepfe Alle").Range("B" & count & ":" & Sheets(ID_number(I) & "_Koepfe Alle").Cells(count, Columns.count).End(xlToLeft).Offset(0, 1).Address)
            .Interior.Pattern = xlSolid
            .Interior.PatternColorIndex = xlAutomatic
            .Interior.ThemeColor = xlThemeColorDark1
            .Interior.TintAndShade = -0.149998474074526
            .Interior.PatternTintAndShade = 0
            .Font.Bold = True
            .VerticalAlignment = xlCenter
            .HorizontalAlignment = xlCenter
        End With
        r_row = Sheets(ID_number(I) & "_Koepfe Alle").Range("B" & count).End(xlDown).Row
        Sheets(ID_number(I) & "_Koepfe Alle").Range("B" & count + 1 & ":B" & r_row - 1).Borders(xlInsideHorizontal).LineStyle = xlNone
        count = r_row
    Loop
    For count = 3 To Range("B" & Rows.count).End(xlUp).Row
        If Not Range("B" & count) = "" Then
            With Sheets(ID_number(I) & "_Koepfe Alle").Range("B" & count & ":E" & count)
                .Borders(xlInsideVertical).LineStyle = xlNone
                .BorderAround xlContinuous
            End With
        ElseIf Not Range("C" & count) = "" Then
            With Sheets(ID_number(I) & "_Koepfe Alle").Range("C" & count & ":E" & count)
                .Borders(xlInsideVertical).LineStyle = xlNone
                .BorderAround xlContinuous
            End With
        End If
    Next count
    Sheets(ID_number(I) & "_Koepfe Alle").Range("D" & Sheets(ID_number(I) & "_Koepfe Alle").Range("D" & Rows.count).End(xlUp).Row + 2 & ":D" & Rows.count).EntireRow.Delete
Next I
Application.ScreenUpdating = True
MsgBox ("Koepfe Alle erfolgreich erstellt!")
'Call KoepfeDetail

End Sub

**Richard Buttrey** · 12-08-2014, 06:01 AM

Hi,

That's rather a lot of code and no doubt could be simplified somewhat. But we need to know what you want to achieve. It's by no means clear what you mean by 'needing a description'.

Let's start from basics. Upload the workbook and manually add the results you expect to see after you have processed the data so that we can decide the optimum solution which will probably look little like your existing code.

**vio.coman** · 12-08-2014, 06:49 AM

Mappe X.xlsm

Richard,
Thank your for your reply.

Please find in the attached workbook the following:
1. The Input worksheet “Vergütungsdaten_M” (=> the data to be processed)
2. The Output worksheet “22_Koepfe Detail” (=> the result expected to see)
3. The auxiliary worksheet “Aux”
4. The code is available in Module 1.

Please note that the output worksheet needs to be deleted each time before running the code.

What I would need, is a so-called guide through the code, namely a short description of the operations/command blocks in the code.
It is good to hear that the code could be simplified; sadly I do not have the knowledge to do it.

Once again, thanks a lot!

**Richard Buttrey** · 12-08-2014, 07:11 AM

Hi,

Where do the column CK & CT values come from and is the Koepfe column Q the number that appears in the various date columns.

**Richard Buttrey** · 12-08-2014, 10:01 AM

Hi,

Add another 'Results Sheet' (make sure it has the VBA sheet code name 'Sheet1' and then run this macro.

Sub Results()
    Dim llastrow As Long, x As Long
    Dim DateCols, ColHeaders, Dates(10)

    'Add Helper Columns
    Tabelle85.Range("A1:K1").EntireColumn.Insert
    With Tabelle85
        .Range("A3") = "=IF(AND(M3<>"""",M3<>M2),M3,A2)"
        .Range("B3") = "=IF(AND(N3<>"""",N3<>N2),N3,B2)"
        .Range("C3") = "=IF($K3=""Y"",O3,"""")"
        .Range("D3") = "=IF($K3=""Y"",P3,"""")"
        .Range("E3") = "=INDEX(Aux!T:T,MATCH(IF($K3=""Y"",B3,""""),Aux!S:S,1),1)"
        .Range("G3") = "HC"
        .Range("H3") = "=IF($K3=""Y"",B3,"""")"
        .Range("I3") = "=IF($K3=""Y"",A3,"""")"
        .Range("J3") = "=IF($K3=""Y"",""acktiv"","""")"
        .Range("K3") = "=IF(O3<>"""",""Y"",""N"")"
    End With

    llastrow = Tabelle85.Range("M" & Rows.Count).End(xlUp).Row

    Tabelle85.Range("A3:K3").Copy Destination:=Tabelle85.Range("A3:A" & llastrow)

    'clear current results
    Sheet1.Range("A5").CurrentRegion.Offset(1, 0).ClearContents

    DateCols = Array("Q", "R", "U", "X", "AA", "AD", "AG", "AJ", "AM", "AP")
    ColHeaders = Array("Stichtag", "EmplID", "Name", "Manager Number", "Koepfe", "HC", "Manager", "Team", "Status2", "YN")
    
    For x = 0 To 9
        Sheet1.Range("A5").Cells(1, x + 1) = ColHeaders(x)
    Next x
    
    For x = 0 To 9
        Dates(x) = WorksheetFunction.EoMonth(DateSerial(Right(Tabelle85.Range(DateCols(x) & 2), 2) + 2000, Left(Tabelle85.Range(DateCols(x) & 2), 2), 1), 0)
        Sheet1.Range("A" & Rows.Count).End(xlUp).Cells(2, 1).Resize(llastrow - 4, 1) = Dates(x)
        Tabelle85.Range("C5:K" & llastrow).Copy
        Sheet1.Range("J" & Rows.Count).End(xlUp).Cells(2, -7).PasteSpecial (xlPasteValues)
        Tabelle85.Range(DateCols(x) & "5:" & DateCols(x) & llastrow).Copy
        Sheet1.Range("E" & Rows.Count).End(xlUp).Cells(2, 1).PasteSpecial (xlPasteValues)
    Next x
    
    Sheet1.Range("J5").AutoFilter field:=10, Criteria1:="N"
    Sheet1.Range("A5").CurrentRegion.Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete
    Sheet1.Range("J5").AutoFilter
    Sheet1.Range("J1").EntireColumn.Delete

    Tabelle85.Range("A1:K1").EntireColumn.Delete

End Sub

**vio.coman** · 12-08-2014, 08:04 AM

Richard,

That is correct; the Koepfe column Q is the number that appears in the various date columns.

The columns CK & CT values represent additional information that I use and that will be always available, at it comes directly out of our systems. In other words, only those employees will be collected and listen in worksheet “22_Koepfe Detail” that fulfill the condition “HC” in column “CK” and “aktiv” in column “CT”, respectively.

Thanks again!

**Richard Buttrey** · 12-08-2014, 09:33 AM

Hi,

I can see that those values appear in the resultant sheet columns CK & CT, my question was where does this information reside in the “22_Koepfe Detail” sheet.

Or are you saying that columns CK & CT should always be populated with HC and aktiv. If so what about those cells in CT which aren't showing just 'aktiv'? e.g. CT20

**vio.coman** · 12-08-2014, 09:57 AM

Richard,

those values in the columns CK & CT are not meant to reside in the “22_Koepfe Detail” sheet. However, they are not less important than the other columns, as they serve as "limiting factors" in the code. For example, the code extracts the data only for those employees that are "aktiv" and "HC", meaning only active headcounts are being extracted and arranged in sheet "22_Koepfe Detail". Consequently, whenever the code finds something like cell CT20, it skips the employee.
I would not mind those two columns very much, as they constitute adjacent information...

regards

**vio.coman** · 12-08-2014, 10:46 AM

Richard,

thank u a lot!
I'm getting an error at

Sheet1.Range("A5").CurrentRegion.Offset(1, 0).ClearContents

I can't really say why..

regards

**Richard Buttrey** · 12-08-2014, 12:09 PM

Hi,

Have you added a new sheet and checked that it has the VB code name 'Sheet1'. You can name the tab name anything you like. This sheet will contain your results.

**vio.coman** · 12-09-2014, 05:18 AM

Richard,

sorry for my late reply..
It works perfectly and I would gladly replace the initial code that I was using, because it requires a lot of resources for which I need a good machine.
The problem is that, with my old code I create approx. 120-130 of those result sheets, each of which containg different data.
The structure is of course the same, only the manager, the teams and the employees differ.
That means one would have to add around 120 new sheets prior running the code.
Besides, the "Tabelle85" in the code becomes variable, right?

Question: could one go around this manual creation of "Sheet1", "Sheet2", "Sheet3"...,etc. and the "Tabelle85" problem?

Thanks again!

Regards

Code description

LinkBack

Thread Tools

Rate This Thread

Display

Hybrid View

Code description

Re: Code description

Re: Code description

Re: Code description

Re: Code description

Re: Code description

Re: Code description

Re: Code description

Re: Code description

Re: Code description

Re: Code description

Thread Information

Users Browsing this Thread

Similar Threads

Function required to add description to code within spreadsheet

User Input Description to SKU 'Smart Code'

[SOLVED] If code same combine the description

lists in excel how to match code with description

enter item code in one column, automatically get description in ne

Bookmarks

Bookmarks

Posting Permissions