***セルの高さを適当に調節する [#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
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
~
Total=
&counter(total);
Today=    
&counter(today);
~

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