エクセルの部屋

掲示板

Lookupのような関数 †

' 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

同時スクロール †

複数のウインドウを並べて同時にスクロールさせる
２つのウインドウを１行ずつスクロール

Sub WScrollLine()

   Windows(1).Activate
   ActiveWindow.SmallScroll Up:=-1
   Windows(2).Activate
   ActiveWindow.SmallScroll Up:=-1

End Sub

身に覚えのないリンク †

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

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

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

セルの中から１行取り出す(行の区切りは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

アクティブセルを指定したセルにコピーする †

Sub CopyActiveCell(y As Integer, x As Integer)

   Selection.Copy
   
   ActiveCell.Offset(y, x).Select
   ActiveSheet.Paste

End Sub

アクティブセルを指定した数だけ横方向のセルにコピーする †

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

アクティブセルのデータを横方向のセルにコピーする †

'　ここでは、横方向に２６セル、縦方向は７セルずつ移動 ' 縦に７セル移動した後、再度そのセルのデータを横方向にコピーする ' 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

縦方向に７セル毎にセルをコピーする †

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

指定した行を選択してコピーする †

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

'アクティブセルから上の４行を選択して、７行先に（要は間に３行あけて）コピー 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

アクティブセルの上に１行挿入する †

Sub InsertLine()

   ActiveCell.EntireRow.Insert

End Sub

'指定した行間隔で１行ずつ空行を挿入する 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")
   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

アクティブセルの行のカラー設定を変更する †

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= 4802 Today= 3