Posts by nilem

Sub ertert()
Dim Kw, i&, r As Range, adr$
With Sheets("Keywords")
    Kw = .Range("A1", .Cells(Rows.Count, 1).End(xlUp)).Value
End With
'Orders is active sheet
With Range("A1", Cells(Rows.Count, 1).End(xlUp))
    For i = 1 To UBound(Kw)
        Set r = .Find(Kw(i, 1), LookIn:=xlValues, lookat:=xlPart)
        If Not r Is Nothing Then
            adr = r.Address
            Do
                r(1, 2) = IIf(Len(r(1, 2)), r(1, 2) & ", " & Kw(i, 1), Kw(i, 1))
                Set r = .FindNext(r)
            Loop While r.Address <> adr
        End If
    Next i
End With
End Sub

Sub ertert()
Dim Kw, i&, r As Range
With Sheets("Keywords")
    Kw = .Range("A1", .Cells(Rows.Count, 1).End(xlUp)).Value
End With
'Orders is active sheet
With Range("A1", Cells(Rows.Count, 1).End(xlUp))
    For i = 1 To UBound(Kw)
        Set r = .Find(Kw(i, 1), LookIn:=xlValues, lookat:=xlPart)
        If Not r Is Nothing Then
            r(1, 2) = IIf(Len(r(1, 2)), r(1, 2) & ", " & Kw(i, 1), Kw(i, 1))
        End If
    Next i
End With
End Sub

...
'    'Set the cell in column U to house the file name  *** OLD PLACE ***
'    SummarySheet.Range("U" & NRow).Value = FileName


    'Set the range to be A1000 through W1000
    On Error Resume Next
    Set SourceRange = WorkBk.Worksheets(1).Range("A2:M300")
    SrRan = Dir(FolderPath & "*.xls*")
    On Error GoTo 0
    'Set the destination range
    Set DestRange = SummarySheet.Range("A" & NRow)
    Set DestRange = DestRange.Resize(SourceRange.Rows.Count, SourceRange.Columns.Count)


    'Copy over values from the source to the destination
    DestRange.Value = SourceRange.Value




    'Set the cell in column U to house the file name ***NEW PLACE ***
    SummarySheet.Range("U" & NRow).Resize(SourceRange.Rows.Count).Value = FileName
...

Private Sub CmdButtonDelete_Click()
    Call CmdButtonClear_Click
End Sub




Private Sub CmdButtonClear_Click()
For Each oneControl In Me.Controls
    Select Case TypeName(oneControl)
        Case "TextBox"
            oneControl.Value = ""
        Case "ComboBox"
            oneControl.Value = ""
            oneControl.Clear
        Case "CheckBox"
            oneControl.Value = False
            oneControl.Enabled = False
        Case "OptionButton"
            oneControl.Value = False
            oneControl.Enabled = False
    End Select
Next oneControl
End Sub

Sub ertert()
Dim x, y(), i&, s$, k&


With Sheets("Sheet1")
    x = .Range("A1:E" & .Cells(Rows.Count, 2).End(xlUp).Row + 1).Value
End With
ReDim y(1 To UBound(x), 1 To 2)


For i = 1 To UBound(x)
    If x(i, 2) <> s Then
        s = x(i, 2)
        k = k + 1
        Set y(k, 1) = Cells(i, 2)
        If x(i, 5) > 0 Then y(k, 2) = "del"
    Else
        Set y(k, 1) = Union(y(k, 1), Cells(i, 2))
        If x(i, 5) < 0 Then y(k, 2) = ""
    End If
Next i


For i = k To 1 Step -1
    If y(i, 2) = "del" Then y(i, 1).EntireRow.Delete
Next i
End Sub

Sub ertert()
Dim sNum$
sNum = Range("A1").Value '11, 14, 35-37, 39-41, 49-51, 57-58, ...
sNum = ExpandStr(sNum)
Range("A2").Value = ConcNum(sNum)
End Sub


Function ConcNum(sConc As String) As String
Dim s$, x, i&, bu As Boolean
x = Split(sConc & "~", "~")
If UBound(x) = 0 Then ConcNum = x(0): Exit Function
For i = 0 To UBound(x) - 1
    s = s & ", " & Trim(x(i))
    Do While Val(x(i)) = Val(x(i + 1)) - 1
        bu = True: i = i + 1
    Loop
    If bu Then s = s & "-" & Trim(x(i)): bu = False
Next i
ConcNum = Mid(s, 3)
End Function


Function ExpandStr(sExp As String) As String
Dim sp, v, i&
With CreateObject("System.Collections.ArrayList")
    For Each v In Split(sExp, ",")
        If InStr(v, "-") Then
            sp = Split(Trim(v), "-")
            For i = sp(0) To sp(UBound(sp))
                .Add i
            Next
        Else
            .Add CLng(Trim(v))
        End If
    Next v
    .Sort
    ExpandStr = Join(.toarray, "~")
End With
End Function

Sub ertert()
Dim x, y(), i&, j&, Dk, k, s$, t()
Dim wsh As Worksheet, wb As Workbook
Dim D As Object
Set D = CreateObject("Scripting.Dictionary"): D.CompareMode = 1
With Application
    Application.ScreenUpdating = False: .DisplayAlerts = False
End With


With CreateObject("Scripting.Dictionary")
    .CompareMode = 1
    For Each wsh In ThisWorkbook.Sheets
        x = wsh.UsedRange.Value
        For i = 2 To UBound(x)
            If Len(x(i, 1)) = 0 Then Exit For
            If Not D.exists(x(i, 1)) Then D.Item(x(i, 1)) = Empty
            s = x(i, 1) & "~" & wsh.Name
            If .exists(s) Then
                t = .Item(s): t(1) = t(1) + 1
                For j = 1 To UBound(x, 2)
                    t(0)(t(1), j) = x(i, j)
                Next
                .Item(s) = t()
            Else
                ReDim y(1 To UBound(x), 1 To UBound(x, 2))
                For j = 1 To UBound(x, 2)
                    y(1, j) = x(1, j): y(2, j) = x(i, j)
                Next
                .Item(s) = Array(y, 2)
            End If
        Next i
    Next wsh


    For Each Dk In D.keys
        Set wb = Workbooks.Add(xlWBATWorksheet)
        For Each k In .keys
            If Split(k, "~")(0) = Dk Then
                wb.Sheets.Add After:=wb.Sheets(wb.Sheets.Count)
                ActiveSheet.Name = Split(k, "~")(1)
                t = .Item(k)(0)
                Range("A1").Resize(.Item(k)(1), UBound(t, 2)).Value = t()
                .Remove k
            End If
        Next k
        With wb
            .Sheets(1).Delete
            .SaveAs ThisWorkbook.Path & "\" & Dk & ".xlsx"
            .Close
        End With
    Next Dk
End With
With Application
    Application.ScreenUpdating = True: .DisplayAlerts = True
End With


Set D = Nothing
End Sub

Sub ertert()
Dim x, y(), i&, j&, s$, k&
k = Application.InputBox("Enter 3 or 4 or 5", Default:=3, Type:=1)
If k = 0 Then Exit Sub
x = Range("A1", Cells(Rows.Count, 1).End(xlUp)).Value
ReDim y(1 To UBound(x), 1 To 1)


With CreateObject("Scripting.Dictionary")
    .CompareMode = 1
    For i = 1 To UBound(x, 1) - k - 1
        For j = i To i + k - 1
            s = s & x(j, 1)
        Next j
        If .exists(s) Then
            For j = .Item(s) To .Item(s) + k - 1
                y(j, 1) = "match"
            Next j
            For j = i To i + k - 1
                y(j, 1) = "match"
            Next j
        Else
            .Item(s) = i
        End If
        s = vbNullString
    Next i
End With


Range("B1").Resize(UBound(y)).Value = y
End Sub

Sub ertert()
Dim r As Range, rHd As Range, i&
i = Application.InputBox("Enter 1 or 2 or 3", Default:=1, Type:=1)
If i = 0 Then Exit Sub
Application.ScreenUpdating = False
Set rHd = Range("A1")
ActiveSheet.Cells.EntireRow.Hidden = False
With Range("B4:D" & Cells(Rows.Count, 2).End(xlUp).Row)
    For Each r In .Columns(i).Cells
        If Len(r) < 3 Then Set rHd = Union(r, rHd)
    Next r
    If rHd.Count > 1 Then Intersect(rHd, .Columns(i)).EntireRow.Hidden = True
End With
Application.ScreenUpdating = True
End Sub

Sub ertert()
Dim shp As Shape, r As Range, desc$, clr&


For Each shp In Sheets("OUTPUT").Shapes
'    MsgBox shp.Name
    Set r = Sheets("TRACKER").Columns(1).Find(shp.Name, LookIn:=xlValues, lookat:=xlWhole)
    If Not r Is Nothing Then
        desc = r(1, 2).Value & r(1, 3).Value
        Set r = Sheets("Appendix").Columns(13).Find(desc, LookIn:=xlValues, lookat:=xlWhole)
        If Not r Is Nothing Then
            clr = r(1, 0).Interior.Color
            shp.Fill.ForeColor.RGB = RGB(clr \ 256 ^ 0 And 255, clr \ 256 ^ 1 And 255, clr \ 256 ^ 2 And 255)
            shp.Line.ForeColor.RGB = RGB(clr \ 256 ^ 0 And 255, clr \ 256 ^ 1 And 255, clr \ 256 ^ 2 And 255)
        Else
            MsgBox "not found Description " & desc, 64
        End If
    Else
        MsgBox "not found Name " & shp.Name, 64
    End If
Next
End Sub