[[掲示板:http://mift.jp/bbs/bbs.php]]~

#contents

***Lookupのような関数 [#u98d869e]

 Function xLookUp(a, b)
 'aと一致するセルをb列から検索して、
 'そのセルの右隣のセル値を返す
    pos = b.Row
    For i = 1 To b.Count
        If a = Cells(pos, b.Column) Then
            xLookUp = Cells(pos, b.Column + 1)
            Exit Function
        End If
        pos = pos + 1
    Next i
    xLookUp = 0
 End Function

***同時スクロール [#f25fa733]

 複数のウインドウを並べて同時にスクロールさせる
 2つのウインドウを1行ずつスクロール
Sub WScrollLine()
    Windows(1).Activate
    ActiveWindow.SmallScroll Up:=-1
    Windows(2).Activate
    ActiveWindow.SmallScroll Up:=-1
End Sub

***身に覚えのないリンク [#r2a5aab8]

 メニュー→挿入→名前→定義
 で、表示されるボックスの中に身に覚えのない名前があると
 それが定義されているリンクが、身に覚えのないリンクの正体です。
 例えば、Aさんが自分の環境でabc.xlsを作ります。
 そこに、別のファイルからabcと言う名前参照して使ってしまうと、
 abc.xlsの全部のセルデータを消しても、リンク情報だけ残ります。

***セルの高さを適当に調節する [#h6d55ba4]

Function LineCount(DestStrings As String) As Integer
    Dim LineNum As Integer
    Dim CharNum As Integer
    Dim CWidth As Integer
    Dim CharMax As Integer
    
    CWidth = ActiveCell.Cells.ColumnWidth
    CWidth = ActiveCell.Cells.Width
    CharMax = CWidth / ActiveCell.Cells.Font.Size
    
    CharNum = 0
    LineNum = 0
    length = Len(DestStrings)
    For i = 1 To length
        If (Mid(DestStrings, i, 1) = Chr(10)) Then
'            LineNum = LineNum + 1
            LineNum = LineNum + Int(((CharNum + (CharMax - 1)) / CharMax))
            CharNum = 0
        Else
            CharNum = CharNum + 1
        End If
    Next i
    
    If (CharNum <> 0) Then
        LineNum = LineNum + 1
    End If
    LineCount = LineNum
End Function

Sub Takasa(TakasaAdjust As Double)
    Dim CellStrings As String
    
    CellStrings = ActiveCell.FormulaR1C1
    LineNum = LineCount(CellStrings)
    FontSize = ActiveCell.Cells.Font.Size
    NewHeight = (LineNum + 1) * FontSize * TakasaAdjust
    If (NewHeight > 400) Then
        NewHeight = 400
    End If
    ActiveCell.Cells.RowHeight = NewHeight
    ActiveCell.Offset(0, 1).FormulaR1C1 = LineNum
End Sub

Sub TakasaAll()
    Dim TakasaSize As String
    Dim Machi As String
    Dim TakasaAdjust As Double
    Dim MachiJikan As Integer
    
    TakasaSize = InputBox("高さ調節サイズを指定してください(1.2位がおすすめ)")
    If (TakasaSize = "") Then
        TakasaAdjust = 1
    Else
        TakasaAdjust = Val(TakasaSize)
    End If
    Machi = InputBox("セル毎の処理待ち時間を秒で指定してください(0〜59)")
    MachiJikan = Val(Machi)
    For i = 1 To 10000
        If (ActiveCell.FormulaR1C1 = "") Then
            Exit For
        End If
        Takasa (TakasaAdjust)
        ActiveCell.Offset(1).Select
        If (MachiJikan <> 0) Then
            If (WaitSec(MachiJikan) = False) Then
                Exit For
            End If
        End If
    Next i
End Sub

***指定した秒数だけ待つ [#o4b9b8c8]
Function WaitSec(WaitTime As Integer) As Boolean
    Dim TimeStr As String
    
    TimeStr = "0:00:" & Trim(Str(WaitTime))
    WaitSec = Application.Wait(Now + TimeValue(TimeStr))
End Function

***セルの中から1行取り出す(行の区切りは0x0a) [#qb06c92f]
Function GetStrings(StringsBuffer As String, LineStrings As String, pos As Integer) As Integer
    Dim length As Integer
    Dim workbuffer As String
    
    length = Len(StringsBuffer)
    For i = pos To length
        If (Mid(StringsBuffer, i, 1) = Chr(10)) Then
            workbuffer = workbuffer + Mid(StringsBuffer, i, 1)
            Exit For
        End If
        workbuffer = workbuffer + Mid(StringsBuffer, i, 1)
    Next i
    LineStrings = workbuffer
    GetStrings = i
End Function

***数値判定 [#m3624cc6]
Function IsIntDigit(SourceStrings As String, Digit As Integer) As Boolean
    Dim i As Integer
    Dim length As Integer
    
    length = Len(SourceStrings)
    For i = 1 To length
        If ((Mid(SourceStrings, i, 1) < "0") Or (Mid(SourceStrings, i, 1) > "9")) Then
            IsIntDigit = False
            Digit = 0
            Exit Function
        End If
    Next i
    Digit = Val(SourceStrings)
    IsIntDigit = True
End Function

***セルの中の(x)のxをカウントアップする [#ze6d64c3]
Function CountUp(SourceStrings As String, BaseNo As Integer, first As Boolean) As String
    '(まではそのままコピー (は除く
    Dim NoStrings As String
    Dim tmpNo As Integer
    
    length = Len(SourceStrings)
    For i = 1 To length
        c = Mid(SourceStrings, i, 1)
        If (c = "(") Then
            Exit For
        End If
        DestStrings = DestStrings + c
    Next i
    If (c <> "(") Then
        CountUp = SourceStrings
        Exit Function
    End If
    ')までは数値として取り込む
    For i = i + 1 To length
        c = Mid(SourceStrings, i, 1)
        If (c = ")") Then
            Exit For
        End If
        NoStrings = NoStrings + c
    Next i
    If (c <> ")") Then
        CountUp = SourceStrings
        Exit Function
    End If
    
    If (IsIntDigit(NoStrings, tmpNo) = True) Then
        If (first = True) Then
            CountUp = DestStrings + "(" + Trim(Str(tmpNo)) + ")" + Mid(SourceStrings, i + 1)
            BaseNo = tmpNo
        Else
            CountUp = DestStrings + "(" + Trim(Str(BaseNo)) + ")" + Mid(SourceStrings, i + 1)
        End If
    End If
End Function

Sub test()
    Dim StringsBuffer As String
    Dim LineStrings As String
    Dim BufferLength As Integer
    Dim nextpos As Integer
    Dim pos As Integer
    Dim savepos As Integer
    
    
    StringsBuffer = ActiveCell.FormulaR1C1
    nextpos = 0
    savepos = 1
    Do
        pos = nextpos + 1
        nextpos = GetStrings(StringsBuffer, LineStrings, pos)
        ActiveCell.Cells.Offset(1).Select
        ActiveCell.FormulaR1C1 = LineStrings
        savepos = savepos + 1
    Loop While nextpos <> pos
    
End Sub

Sub test2()
    Dim LineStrings As String
    Dim StringsBuffer As String
    Dim ResultStrings As String
    Dim BufferLength As Integer
    Dim nextpos As Integer
    Dim pos As Integer
    Dim savepos As Integer
    Dim No As Integer
    Dim first As Boolean
    
    StringsBuffer = ActiveCell.FormulaR1C1
    nextpos = 0
    savepos = 1
    No = -1
    first = True
    Do
        pos = nextpos + 1
        nextpos = GetStrings(StringsBuffer, LineStrings, pos)
        savepos = savepos + 1
        If (Mid(LineStrings, 1, 1) <> "(") Then
            ResultStrings = ResultStrings + LineStrings
        Else
            ResultStrings = ResultStrings + CountUp(LineStrings, No, first)
            first = False
            No = No + 1
        End If
    Loop While nextpos <> pos
    ActiveCell.Offset(1).Select
    ActiveCell.FormulaR1C1 = ResultStrings
    
End Sub

***アクティブセルを指定したセルにコピーする [#fcacb7cc]
Sub CopyActiveCell(y As Integer, x As Integer)
    Selection.Copy
    
    ActiveCell.Offset(y, x).Select
    ActiveSheet.Paste
End Sub

***アクティブセルを指定した数だけ横方向のセルにコピーする [#q528decd]
Sub CopyYokoCell(num As Integer)
    Dim i As Integer
    
    Selection.Copy
    
    For i = 1 To num
        ActiveCell.Offset(0, 1).Select
        ActiveSheet.Paste
    Next i
End Sub

***アクティブセルのデータを横方向のセルにコピーする [#h076409a]
' ここでは、横方向に26セル、縦方向は7セルずつ移動
'  縦に7セル移動した後、再度そのセルのデータを横方向にコピーする
'  A1のセルデータがA2〜A27へ、H1のセルデータがH2〜H27
'      A1 -> A2 -> A3 ... -> A27
'      ..
'      H1 -> H2 -> H3 ... -> H27
'      ..
    Dim StrMachi As String
    Dim IntMachi As Integer
    Dim i As Integer
    Dim StrStepLine As String
    Dim IntStepLine As Integer
    
    StrMachi = InputBox("セル毎の処理待ち時間を秒で指定してください(0〜59)", , "0")
    If (StrMachi = "") Then
        Exit Sub
    End If
    If (IsIntDigit(StrMachi, IntMachi) = False) Then
        IntMachi = 0
    End If
    IntStepLine = 1
    For i = 1 To 10000 Step IntStepLine
        If (ActiveCell.FormulaR1C1 = "") Then
            Exit For
        End If
        
        CopyYokoCell (26)
        ActiveCell.Offset(7, -26).Select
        If (IntMachi > 0) Then
            If (WaitSec(IntMachi) = False) Then
                Exit For
            End If
        End If
    Next i
End Sub

***縦方向に7セル毎にセルをコピーする [#bda75ca1]
Sub AllCOpyCell()
    Dim StrMachi As String
    Dim IntMachi As Integer
    Dim i As Integer
    Dim StrStepLineStr As String
    Dim IntStepLine As Integer
    
    StrMachi = InputBox("セル毎の処理待ち時間を秒で指定してください(0〜59)", , "0")
    If (StrMachi = "") Then
        Exit Sub
    End If
    If (IsIntDigit(StrMachi, IntMachi) = False) Then
        IntMachi = 0
    End If
    IntStepLine = 1
    
    For i = 1 To 10000 Step IntStepLine
        If (i <> 1) Then
            ActiveCell.Offset(1).Select
        End If
        If (ActiveCell.FormulaR1C1 = "x") Then
            Exit For
        End If
        If (i <> 1) Then
            ActiveCell.Offset(-1).Select
        End If
        
        Call CopyActiveCell(7, 0)
        If (IntMachi > 0) Then
            If (WaitSec(IntMachi) = False) Then
                Exit For
            End If
        End If
    Next i
End Sub

***指定した行を選択してコピーする [#rf83fdd8]
Sub CopyLineData(y As Integer, z As Integer)
    Dim x As Integer
    Dim StrTargetRows As String
    Dim StrDestRows As String
    
    x = ActiveCell.Row
    StrTargetRows = Trim(Str(x)) + ":" + Trim(Str(x + (y - 1)))
    Rows(StrTargetRows).Select
    Selection.Copy
    StrDestRows = Trim(Str(x + z)) + ":" + Trim(Str(x + z))
    Rows(StrDestRows).Select
    ActiveSheet.Paste
End Sub

'アクティブセルから上の4行を選択して、7行先に(要は間に3行あけて)コピー
Sub AllCopyLineData()
    Dim StrMachi As String
    Dim IntMachi As Integer
    Dim i As Integer
    Dim StrStepLine As String
    Dim IntStepLine As Integer
    Dim IntSelectLine As Integer
    Dim IntNextLine As Integer
    
    IntSelectLine = 4
    IntNextLine = 7
    StrMachi = InputBox("セル毎の処理待ち時間を秒で指定してください(0〜59)", , "0")
    If (StrMachi = "") Then
        Exit Sub
    End If
    If (IsIntDigit(StrMachi, IntMachi) = False) Then
        IntMachi = 0
    End If
    IntStepLine = 1
    For i = 1 To 10000 Step IntStepLine
        If (ActiveCell.FormulaR1C1 = "") Then
            Exit For
        End If
        ActiveCell.Offset(0 - IntSelectLine).Select
        Call CopyLineData(IntSelectLine, IntNextLine)
        If (IntMachi > 0) Then
            If (WaitSec(IntMachi) = False) Then
                Exit For
            End If
        End If
        ActiveCell.Offset(IntSelectLine).Select
    Next i
End Sub

***アクティブセルの上に1行挿入する [#z4661b81]
Sub InsertLine()
    ActiveCell.EntireRow.Insert
End Sub

'指定した行間隔で1行ずつ空行を挿入する
Sub AllInsertLine()
    Dim IntMachi As Integer
    Dim StrMachi As String
    Dim i As Integer
    Dim IntLineStep As Integer
    Dim StrLineStep As String
    
    StrLineStep = InputBox("何行おきに空白行を挿入しますか(空白行は選択されているセルの上に1行挿入されます(1〜)", , "1")
    If (StrLineStep = "") Then
        Exit Sub
    End If
    If (IsIntDigit(StrLineStep, IntLineStep) = False) Then
        Exit Sub
    End If

    StrMachi = InputBox("セル毎の処理待ち時間を秒で指定してください(0〜59)", , "0")
    If (StrMachi = "") Then
        Exit Sub
    End If
    If (IsIntDigit(StrMachi, IntMachi) = False) Then
        IntMachi = 0
    End If

    For i = 1 To 10000
        If (ActiveCell.FormulaR1C1 = "") Then
            Exit For
        End If
        InsertLine
        
        If (IntMachi > 0) Then
            If (WaitSec(IntMachi) = False) Then
                Exit For
            End If
        End If
        ActiveCell.Offset(IntLineStep + 1).Select
    Next i
End Sub

***アクティブセルの行のカラー設定を変更する [#ab7cc823]
Sub ColorLine()
    Dim IntLinePos As Integer
    
    IntLinePos ActiveCell.Row
    Rows(IntLinePos).Select
    With Selection.Interior
        .ColorIndex = 34
        .Pattern = xlSolid
    End With
End Sub

'指定した行間隔で、塗りつぶしカラーを設定する
Sub AllColorLine()
    Dim IntMachi As Integer
    Dim StrMachi As String
    Dim i As Integer
    Dim StrStepLine As String
    Dim IntStepLine As Integer
    
    StrStepLine = InputBox("何行おきに色を設定しますか?(1ですべての行)", , "1")
    If (StrStepLine = "") Then
        Exit Sub    'キャンセルされた
    End If
    IntStepLine = Val(StrStepLine)
    
    StrMachi = InputBox("セル毎の処理待ち時間を秒で指定してください(0〜59)", , "0")
    If (StrMachi = "") Then
        Exit Sub
    End If
    If (IsIntDigit(StrMachi, IntMachi) = False) Then
        IntMachi = 0
    End If

    For i = 1 To 10000 Step IntStepLine
        If (ActiveCell.FormulaR1C1 = "") Then
            Exit For
        End If
        ColorLine
        
        If (IntMachi > 0) Then
            If (WaitSec(IntMachi) = False) Then
                Exit For
            End If
        End If
        ActiveCell.Offset(IntStepLine).Select
    Next i
End Sub

~
Total=
&counter(total);
Today=    
&counter(today);
~

トップ   一覧 単語検索 最終更新   ヘルプ   最終更新のRSS