Posts by shknbk2

Sub test()
    Debug.Print groupArray("$A$1,$A$2,$A$3,$A$7,$A$9,$A$10,$A$11")
End Sub




Function groupArray(list As String) As String
    Dim a As Variant, b() As String, c As Variant
    Dim i As Integer, s As String
    
    a = Split(list, ",")
    ReDim b(UBound(a))
    For i = LBound(a) To UBound(a)
        c = Split(a(i), "$")
        b(i) = c(2)
    Next i
    For i = LBound(a) + 2 To UBound(a)
        If b(i - 1) = b(i - 2) + 1 And b(i - 1) = b(i) - 1 Then
            a(i - 1) = ":"
        End If
    Next
    s = a(LBound(a))
    For i = LBound(a) + 1 To UBound(a)
        If a(i) = ":" And Right(s, 1) <> ":" Then
            s = s & ":"
        ElseIf a(i) <> ":" And Right(s, 1) = ":" Then
            s = s & a(i)
        ElseIf a(i) <> ":" And Right(s, 1) <> ":" Then
            s = s & "," & a(i)
        End If
    Next i
    groupArray = s
End Function

Sub ExcelToTally_V2()
    Dim r As Range
    Dim rTemp(6) As Range
    
    Set r = Sheet15.Range("D3")
    If r.Value > 0 Then
        Dim sh1 As Worksheet
        Set sh1 = ActiveWorkbook.Worksheets("V2")
        Windows("Vouchers - Purchase Transactions With StockItems.xlsm").Activate
        On Error Resume Next
        With sh1
            Set rTemp(0) = .Range("C5:C54").SpecialCells(xlCellTypeVisible)
            Set rTemp(1) = .Range("E5:E54").SpecialCells(xlCellTypeVisible)
            Set rTemp(2) = .Range("F5:F54").SpecialCells(xlCellTypeVisible)
            Set rTemp(3) = .Range("G5:G54").SpecialCells(xlCellTypeVisible)
            Set rTemp(4) = .Range("H5:H54").SpecialCells(xlCellTypeVisible)
            Set rTemp(5) = .Range("I5:I54").SpecialCells(xlCellTypeVisible)
            pasteValues rTemp(0), "D"
            pasteValues rTemp(1), "F"
            pasteValues rTemp(2), "H"
            pasteValues rTemp(3), "J"
            pasteValues rTemp(4), "E"
            pasteValues rTemp(5), "C"
        End With
    Else
        Exit Sub
    End If
End Sub




Sub pasteValues(r As Range, s As String)
    Dim i As Integer, c As Range, destination As Range
    i = 0
    Set destination = Range(r & Rows.Count).End(xlUp).Offset(1, 0)
    
    For Each c In r
        destination.Offset(i, 0).Value = c.Value
        i = i + 1
    Next
End Sub

Sub RenameTabsV2()
    Dim Wb As Workbook
    Dim ws As Worksheet
    Dim rng1 As Range
    Dim rng2 As Range
    Dim rng3 As Range
    Dim rng4 As Range
    Dim rng5 As Range
    Dim LastRow As Long
    Set Wb = ActiveWorkbook
     'Rename each sheet in workbook
    For Each ws In ActiveWorkbook.Worksheets
        Set rng1 = ws.Range("A:A").Find("Group Number")
        If Not rng1 Is Nothing Then
            ws.Name = rng1.Offset(1, 0).Value
        End If
         'Identify if the data to count is in column E or C then identify the starting and stopping cells for the count
        On Error Resume Next
        If ws.CodeName = "Sheet1" Then
            Set rng2 = ws.Range("E:E").Find("Employee SSN", lookat:=xlPart)
            LastRow = ws.UsedRange.Rows.Count + ws.UsedRange.Rows(1).Row - 1
            Set rng3 = ws.Range("E" & LastRow)
            Set rng4 = ws.Range(rng2.Offset(1, 0), rng3)
        Else
            Set rng2 = ws.Range("C5")
            LastRow = ws.UsedRange.Rows.Count + ws.UsedRange.Rows(1).Row - 1
            Set rng3 = ws.Range("C" & LastRow)
            Set rng4 = ws.Range(rng2, rng3)
        End If
        ws.Range("A1") = countUniques(rng4) 'Temp value to use for testing/verifying the range on each sheet.  To be replaced once the unique counts coding is functional.
         'Range("A1") = "EE Count:"
        Range("B1") = Application.WorksheetFunction.SumProduct((rng4 <> "") / Application.WorksheetFunction.CountIf(rng4, rng4))
    Next ws
End Sub
 
Function countUniques(filterRange As Range) As Integer
    Dim filterCell As Range
     
    Set filterCell = Cells(1, Columns.Count)
    filterRange.AdvancedFilter Action:=xlFilterCopy, _
    CopyToRange:=filterCell, Unique:=True
    countUniques = filterCell.CurrentRegion.Rows.Count
    Columns(filterCell.Column).Delete
    Set filterCell = Nothing
End Function

Sub Updatebutton()
    Dim copyTarget As Range, i As Integer, j As Integer
    
    Sheets("Team Member 1").Range("B18:G50", "I18:o50").Copy
    With Sheets("Team member 1 - Detail")
        Set copyTarget = .Cells(.Rows.Count, 1).End(xlUp).Offset(2, 0)
        copyTarget.PasteSpecial Paste:=xlPasteFormats
        copyTarget.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False
        Application.CutCopyMode = False
    
        j = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
        For i = j - 1 To copyTarget.Row Step -1
            If .Cells(i, 1).Value <> "" Then
                Exit For
            End If
        Next i
        .Rows(i + 1 & ":" & j).Delete
      End With
End Sub

Sub RenameTabsV2()
    Dim Wb As Workbook
    Dim ws As Worksheet
    Dim rng1 As Range
    Dim rng2 As Range
    Dim rng3 As Range
    Dim rng4 As Variant
    Dim rng5 As Range
    Dim LastRow As Long
    Set Wb = ActiveWorkbook
    'Rename each sheet in workbook
    For Each ws In ActiveWorkbook.Worksheets
        Set rng1 = ws.Range("A:A").Find("Group Number")
            If Not rng1 Is Nothing Then
                ws.Name = rng1.Offset(1, 0).Value
            End If
        'Identify if the data to count is in column E or C then identify the starting and stopping cells for the count
        On Error Resume Next
        If ws.CodeName = "Sheet1" Then
            Set rng2 = ws.Range("E:E").Find("Employee SSN", lookat:=xlPart)
            LastRow = ws.UsedRange.Rows.Count + ws.UsedRange.Rows(1).Row - 1
            Set rng3 = ws.Range("E" & LastRow)
            rng4 = rng2.Offset(1, 0).Address & ":" & rng3.Address
        Else
            Set rng2 = ws.Range("C5")
            LastRow = ws.UsedRange.Rows.Count + ws.UsedRange.Rows(1).Row - 1
            Set rng3 = ws.Range("C" & LastRow)
            rng4 = rng2.Address & ":" & rng3.Address
        End If
        ws.Range("A1") = countUniques(rng4) 'Temp value to use for testing/verifying the range on each sheet.  To be replaced once the unique counts coding is functional.
        'Range("A1") = "EE Count:"
        Range("B1") = Application.WorksheetFunction.SumProduct((rng4 <> "") / Application.WorksheetFunction.CountIf(rng4, rng4))
    Next ws
End Sub


Function countUniques(filterRange As Range) As Integer
    Dim filterCell As Range
    
    Set filterCell = Cells(1, Columns.Count)
    filterRange.AdvancedFilter Action:=xlFilterCopy, _
        CopyToRange:=filterCell, Unique:=True
    countUniques = filterCell.CurrentRegion.Rows.Count
    Columns(filterCell.Column).Delete
    Set filterCell = Nothing
End Function