セルの高さを適当に調節する

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

指定した秒数だけ待つ

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)

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をカウントアップする

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= 4930 Today= 1


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