Posts by dangelor

Private Sub CommandButton1_Click()
    Dim rg As Range, c As Range, i As Long, j As Long
    Dim FName As String, sTemp As String
    Dim fSys As Object, fStream As Object

    Set fSys = CreateObject("Scripting.FileSystemObject")
    FName = Application.GetSaveAsFilename(InitialFileName:=(ActiveSheet.Name), FileFilter:="Text Files (*.txt), *.txt")
    Set fStream = fSys.CreateTextFile(FName, True)
    
    Set rg = Selection.CurrentRegion
    For i = 2 To rg.Rows.Count
        For j = 1 To rg.Columns.Count
            Set c = rg.Cells(i, j)
            If Columns(c.Column).Hidden = False Then
                sTemp = sTemp & c.Value & ","
            End If
        Next j
        fStream.WriteLine Left(sTemp, Len(sTemp) - 1)
        sTemp = vbNullString
    Next i
    
    fStream.Close
    Set fStream = Nothing
    Set fSys = Nothing
End Sub

Sub Not_Tested()
    Dim v As Variant, i As Long
    Dim sPath As String, wbS As Workbook, wbD As Workbook
    Dim lRow As Long

    '|| Assumes all files are in the same folder and all files exist. ||
    '|| Change sPath to the correct folder. ||
    sPath = "C:\Temp" & Application.PathSeparator
    
    '|| Add/remove names as needed, with no spaces in between. ||
    v = Split("California,Connecticut,Massachusetts,Nevada,New Jersey,New York,Oregon,Washington", ",")
    
    For i = LBound(v) To UBound(v)
        Set wbS = Workbooks.Open(Filename:=sPath & v(i) & " - Temporary.xlsx")
        Set wbD = Workbooks.Open(Filename:=sPath & v(1) & ".xlsx")
        
        '|| Assumes all data is in the first worksheet in each workbook.
        lRow = wbD.Worksheets(1).Cells(Rows.Count, 1).End(xlUp).Row + 1
        wbS.Worksheets(1).Cells(1, 1).CurrentRegion.Offset(1).Copy wbD.Worksheets(1).Cells(lRow, 1)
        wbS.Close False
        wbD.Close True
        
        '|| The Kill method deletes the file named, with no chance of recovery. ||
        '|| Test code on copies of files only!! ||
        Kill sPath & v(i) & " - Temporary.xlsx"
    Next i
End Sub

Sub test()
    Dim rg As Range, c As Range
    Dim i As Long, j As Long
    Dim v As Variant, x As Long

    'get list of locations
    Set rg = Sheets("Report").Cells(1, 1).CurrentRegion
    On Error Resume Next
    rg.Columns(1).SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=R[-1]C"
    On Error GoTo 0
    With CreateObject("Scripting.Dictionary")
        For Each c In rg.Columns(1).Cells
            .Item(c.Value2) = Empty
        Next c
        v = .keys
    End With
    
    Application.ScreenUpdating = False
    For j = 1 To UBound(v)
        Set rg = Sheets("Report").UsedRange
        rg.AutoFilter 1, v(j)
        Set rg = rg.SpecialCells(xlCellTypeVisible)
        If rg.areas.Count <> 1 Then
            'mark duplicates
            Set rg = rg.areas(2)
            For i = 1 To rg.Rows.Count
                Set c = rg.Cells(i, 7)
                x = WorksheetFunction.CountIf(rg.Columns(7), c)
                If x > 1 Then c.Font.Color = vbRed
            Next i
            Application.DisplayAlerts = False
            
            rg.Columns(1).Merge
            rg.Columns(2).Merge
            Application.DisplayAlerts = True
        End If
        rg.AutoFilter
    Next j
    Application.ScreenUpdating = True
End Sub

Sub Faster_V2()
    Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet
    Dim LR1 As Long, LC3 As Long
    
    ws1 = Workbooks.Open("C:\Users\WolfieeeStyle\Desktop\HotStocks\1.xls").Worksheets(1)
    ws2 = Workbooks.Open("C:\Users\WolfieeeStyle\Desktop\HotStocks\Alert.xlsx").Worksheets(1)
    ws3 = Workbooks.Open("C:\Users\WolfieeeStyle\Desktop\HotStocks\AlertCodes.xlsx").Worksheets(3)
    
    LR1 = ws1.Cells(Rows.Count, 1).End(xlUp).Row
    LC3 = ws3.Cells(1, Columns.Count).End(xlToLeft).Column
    ws2.Cells(1, 1).Resize(LR1 - 1, LC3).Value = ws3.Cells(1, 1).Resize(LR1 - 1, LC3).Value
    
    ws1.Parent.Close False
    ws2.Parent.Close True
    ws3.Parent.Close False
End Sub

Sub G2N()
    Dim MyRows As Long, MyCols As Long, i As Long
    Dim MyHeader As Range, FoundCell As Range

    With ActiveSheet
        MyRows = .Cells(1, 1).End(xlDown).Row
        MyCols = .Cells(1, 1).End(xlToRight).Column
        For i = 1 To MyCols
            Set MyHeader = .Cells(1, i)
            Set FoundCell = Sheets("G2N").Rows(1).Find( _
                what:=MyHeader.Value, _
                LookIn:=xlFormulas, _
                lookat:=xlWhole)
            If Not FoundCell Is Nothing Then
                Range(.Cells(2, i), .Cells(MyRows, i)).Copy
                FoundCell.Offset(1).PasteSpecial Paste:=xlPasteValues
                Application.CutCopyMode = False
            Else
                'Prints to the Immediate window in the VBA editor
                Debug.Print MyHeader.Value, MyHeader.Address
            End If
        Next i
    End With
End Sub

Option Explicit

Sub G2N()
    Dim MyRows As Long, MyCols As Long, i As Long
    Dim MyHeader As Range, FoundCell As Range

    With ActiveSheet
        MyRows = .Cells(1, 1).End(xlDown).Row
        MyCols = .Cells(1, 1).End(xlToRight).Column
        For i = 1 To MyCols
            MyHeader = .Cells(1, i)
            Set FoundCell = Sheets("G2N").Rows(1).Find( _
                what:=MyHeader.Value, _
                LookIn:=xlFormulas, _
                lookat:=xlWhole)
            If Not FoundCell Is Nothing Then
                Range(.Cells(2, i), .Cells(MyRows, i)).Copy
                FoundCell.Offset(1).PasteSpecial Paste:=xlPasteValues
                Application.CutCopyMode = False
            Else
                'Prints to the Immediate window in the VBA editor
                Debug.Print MyHeader.Value, MyHeader.Address
            End If
        Next i
    End With
End Sub

Sub test_v5()
    Dim d1 As Date, d2 As Date
    Dim rg As Range, i As Long
    Dim c As Range, a As Long
    Dim s As String, b As Long
    
    Application.ScreenUpdating = False
    With Sheet1
        Set rg = .Range("A8").CurrentRegion
        d1 = Cells(2, 2).Value
        d2 = Cells(3, 2).Value
        .Cells(3, 6).CurrentRegion.Offset(1).ClearContents
        
        For i = 4 To d2 - d1 + 4
            .Cells(i, 6) = i + d1 - 4
            .Cells(i, 7) = Choose(Weekday(.Cells(i, 6)), "Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat")
        Next i
        
        For i = 4 To .Rows.Count
            a = 0
            If .Cells(i, 6) = vbNullString Then Exit For
            Set c = rg.Find(.Cells(i, 7).Value)
            If Not c Is Nothing Then
                s = c.Address
                Do
                    DoEvents
                    If a = 0 Then
                        .Cells(i, 8) = c.Offset(, 1).Value
                        .Cells(i, 9) = c.Offset(, -1).Value
                        a = a + 1
                    Else
                        .Cells(i, 6).Resize(, 4).Copy
                        .Cells(i, 6).Resize(, 4).Insert shift:=xlDown
                        .Cells(i + 1, 8) = c.Offset(, 1).Value
                        .Cells(i + 1, 9) = c.Offset(, -1).Value
                        a = a + 1
                        i = i + 1
                        b = b + 1
                    End If
                    Set c = rg.FindNext(c)
                Loop While s <> c.Address
            End If
        Next i
        
        Set rg = .Cells(3, 6).CurrentRegion
        For i = rg.Rows.Count To 1 Step -1
            If rg.Cells(i, 3) = "" Then rg.Rows(i).Delete
        Next i
        
    End With
    Application.ScreenUpdating = True
End Sub

Sub test_v4()
    Dim d1 As Date, d2 As Date
    Dim rg As Range, i As Long
    Dim c As Range, a As Long
    Dim s As String

    With Sheet1
        Set rg = .Range("A8:C11")
        d1 = Cells(2, 2).Value
        d2 = Cells(3, 2).Value
        .Cells(3, 6).CurrentRegion.Offset(1).ClearContents
        
        For i = 4 To d2 - d1 + 4
            .Cells(i, 6) = i + d1 - 4
            .Cells(i, 7) = Choose(Weekday(.Cells(i, 6)), "Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat")
        Next i
        
        For i = 4 To d2 - d1 + 4
            a = 0
            Set c = rg.Find(.Cells(i, 7).Value)
            If Not c Is Nothing Then
                s = c.Address
                Do
                    DoEvents
                    If a = 0 Then
                        .Cells(i, 8) = c.Offset(, 1).Value
                        .Cells(i, 9) = c.Offset(, -1).Value
                        a = a + 1
                    Else
                        .Cells(i, 6).Resize(, 4).Copy
                        .Cells(i, 6).Resize(, 4).Insert shift:=xlDown
                        .Cells(i + 1, 8) = c.Offset(, 1).Value
                        .Cells(i + 1, 9) = c.Offset(, -1).Value
                        a = a + 1
                        i = i + 1
                    End If
                    Set c = rg.FindNext(c)
                Loop While s <> c.Address
            End If
        Next i
        
        Set rg = .Cells(3, 6).CurrentRegion
        For i = rg.Rows.Count To 1 Step -1
            If rg.Cells(i, 3) = "" Then rg.Rows(i).Delete
        Next i
        
    End With
End Sub