Posts by junho lee

Option Explicit
Sub Macro1()
    Dim wb As Workbook
    Dim ThisBook As Workbook
    Dim rng As Range
    Dim rng1 As Range
    Dim i As Long
    Dim FCell As Range
    Dim UnionFCell As Range
    Dim FirstAddress As String
    Application.ScreenUpdating = False
    Set ThisBook = ThisWorkbook
    With ThisBook.Worksheets(1)
        Set rng = .Range(.Range("J1"), .Range("J65536").End(xlUp))
    End With
    Set wb = Workbooks("I011RATB.XLS")
    With wb.Worksheets(1)
        Set rng1 = .Range("A1:A" & .Range("A65536").End(xlUp).Row)
    End With
    With rng1
        For i = rng.Cells.Count To 1 Step -1
            If Not IsEmpty(rng.Cells(i).Value) Then
                Set FCell = .Find(What:=rng.Cells(i).Value, After:=.Cells(1), LookIn:= _
                                  xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:= _
                                  xlNext, MatchCase:=False, MatchByte:=False, SearchFormat:=False)
                If Not FCell Is Nothing Then
                    FirstAddress = FCell.Address
                    If FCell.Offset(0, 2).Value <> rng.Cells(i).Offset(0, 8).Value Then _
                       Set UnionFCell = Range(FCell.Offset(0, 2), FCell.Offset(0, 5))
                    Do
                        Set FCell = .FindNext(After:=FCell)
                        If FCell.Offset(0, 2).Value <> rng.Cells(i).Offset(0, 8).Value Then
                            If UnionFCell Is Nothing Then
                                Set UnionFCell = Range(FCell.Offset(0, 2), FCell.Offset(0, 5))
                            Else
                                Set UnionFCell = Union(UnionFCell, Range(FCell.Offset(0, 2), FCell.Offset(0, 5)))
                            End If
                        End If
                    Loop While Not FCell Is Nothing And FirstAddress <> FCell.Address
                    If Not UnionFCell Is Nothing Then
                        ThisBook.Worksheets(1).Rows(rng.Cells(i).Row + 1 & ":" & rng.Cells(i).Row + CountRowsUnionRange(UnionFCell)).Insert Shift:=xlDown
                        UnionFCell.Copy rng.Cells(i).Offset(1, 9)
                        Set UnionFCell = Nothing
                        Set FCell = Nothing
                    End If
                End If
            End If
        Next
    End With
    ThisBook.Activate
    Application.ScreenUpdating = True
End Sub
Function CountRowsUnionRange(UnionRange As Range) As Long
    Dim uArea As Range
    For Each uArea In UnionRange.Areas
        CountRowsUnionRange = CountRowsUnionRange + uArea.Rows.Count
    Next
End Function

obj.ShapeRange.Fill.Transparency = 1#
'recoder
    'ActiveSheet.Shapes("CommandButton1").Select
    'Selection.ShapeRange.Fill.Visible = msoTrue
    'Selection.ShapeRange.Fill.Solid
    'Selection.ShapeRange.Fill.ForeColor.SchemeColor = 65
    'Selection.ShapeRange.Fill.Transparency = 1#
    'Selection.ShapeRange.Line.Weight = 0.75
    'Selection.ShapeRange.Line.DashStyle = msoLineSolid
    'Selection.ShapeRange.Line.Style = msoLineSingle
    'Selection.ShapeRange.Line.Transparency = 0#
    'Selection.ShapeRange.Line.Visible = msoFalse

Function DayBefore(DayNow As Double, RetroDays As Double) As Double
    Dim DayMinus As Double
    Dim wd As Integer
    Dim SevenDays As Integer
    wd = Weekday(DayNow, 2)
    If RetroDays > 5 Then
        SevenDays = Int(RetroDays / 5) * 7
        DayMinus = RetroDays - Int(RetroDays / 5) * 5
    Else
        DayMinus = RetroDays
    End If
    If DayMinus >= wd Then DayMinus = DayMinus + 2
    DayBefore = DayNow - (DayMinus + SevenDays)
End Function

Sub AutoFilterDayBefore()
Debug.Print Format(DayBefore(Now(), 30), "mm/dd/yyyy")
Range("A1:P" & Cells(Rows.Count, "A").End(xlUp).Row).AutoFilter Field:=8, _
Criteria1:=">=" & Format(DayBefore(Now(), 3), "mm/dd/yyyy")
End Sub
Function DayBefore(DayNow As Long, RetroDays As Long) As Long
    Dim DayMinus As Long
    Dim wd As Integer
    Dim DayHour As Long
    DayHour = DayNow - Int(DayNow)
    DayNow = Int(DayNow)
    While DayMinus < RetroDays
    wd = Weekday(DayNow)
        If wd = 1 Or wd = 7 Then
            DayNow = DayNow - 1
        Else
            DayNow = DayNow - 1
            DayMinus = DayMinus + 1
        End If
    Wend
    DayBefore = DayNow + DayHour
End Function

Function DayBefore(DayNow As Long, RetroDays As Long) As Long
    Dim DayMinus As Long
    Dim wd As Integer
    Dim DayHour As Long
    DayHour = DayNow - Int(DayNow)
    DayNow = Int(DayNow)
    While DayMinus < RetroDays
    wd = Weekday(DayNow)
        If wd = 1 Or wd = 7 Then
            DayNow = DayNow - 1
        Else
            DayNow = DayNow - 1
            DayMinus = DayMinus + 1
        End If
    Wend
    DayBefore = DayNow + DayHour
End Function

Sub CopyChart()
'
' CopyChart Macro
' Macro recorded 10/13/2010 by kw
'
'
Dim i As Integer, j As Integer
    If ActiveSheet.ChartObjects.Count > 1 Then
        j = ActiveSheet.ChartObjects.Count
        For i = j To 2 Step -1
            ActiveSheet.ChartObjects(i).Delete
        Next
    End If
    For i = 1 To Sheets("Sheet1").Range("A1").CurrentRegion.Rows.Count - 2
        ActiveSheet.ChartObjects("Chart 1").Activate
        With ActiveChart
            .ChartArea.Select
            .ChartArea.Copy
        End With
        ActiveWindow.Visible = False
        Range("A12:I21").Offset((i - 1) * 10, 0).Select
        ActiveSheet.Paste
        With ActiveChart
            .SeriesCollection(1).Values = "=Sheet1!R" & i + 2 & "C2:R" & i + 2 & "C4"
            .SeriesCollection(2).Values = "=Sheet1!R" & i + 2 & "C6:R" & i + 2 & "C8"
            .SeriesCollection(3).Values = "=Sheet1!R" & i + 2 & "C10:R" & i + 2 & "C12"
        End With
    Next
End Sub

Option Explicit
Sub ImportWebData()
    Dim LastColumn As Integer
    Dim i As Integer
    Application.ScreenUpdating = False
    Application.Calculation = xlManual
    With Sheet1
        LastColumn = .Range("B4").End(xlToRight).Column
    End With
    For i = 2 To LastColumn
        With Sheets("Query")
            .UsedRange.ClearContents
        End With
        WebQuery Sheet1.Cells(4, i).Text
        With Sheet1
            'Add each matching data
            .Cells(6, i) = Sheets("Query").Range("B6")
            .Cells(7, i) = Sheets("Query").Range("C6")
            '...
            '...and so on
        End With
    Next
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
End Sub
Sub WebQuery(ticker As String)
    With Sheets("Query").QueryTables.Add(Connection:= _
                                         "URL;http://moneycentral.msn.com/investor/research/sreport.asp?Symbol=" & ticker & "&FRK=1&Type=Equity" _
                                         , Destination:=Sheets("Query").Range("A1"))
        .Name = "sreport.asp?Symbol=" & ticker & "&FRK=1&Type=Equity"
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .BackgroundQuery = True
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .WebSelectionType = xlSpecifiedTables
        .WebFormatting = xlWebFormattingNone
        .WebTables = "2,3,4,6,7,8,9,10"
        .WebPreFormattedTextToColumns = True
        .WebConsecutiveDelimitersAsOne = True
        .WebSingleBlockTextImport = False
        .WebDisableDateRecognition = False
        .WebDisableRedirections = False
        .Refresh BackgroundQuery:=False
    End With
End Sub