[[掲示板:http://mift.jp/bbs/bbs.php]]~
 
 #contents
 
 ***Lookupのような関数 [#u98d869e]
 
  Function xLookUp(a, b)
 ' xLookUp(a1,a1:a99, 2, "他のシート")
  Function xLookUp(a, b, off, Optional c As String = "")
  'aと一致するセルをb列から検索して、
  'そのセルの右隣のセル値を返す
     pos = b.Row
     Dim strSheetName As String
     If c = "" Then
         strSheetName = ActiveSheet.Name
     Else
         strSheetName = c
     End If
     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