***セルの高さを適当に調節する [#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