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 同時スクロール †複数のウインドウを並べて同時にスクロールさせる 2つのウインドウを1行ずつスクロール Sub WScrollLine() Windows(1).Activate ActiveWindow.SmallScroll Up:=-1 Windows(2).Activate ActiveWindow.SmallScroll Up:=-1 End Sub 身に覚えのないリンク †メニュー→挿入→名前→定義 で、表示されるボックスの中に身に覚えのない名前があると それが定義されているリンクが、身に覚えのないリンクの正体です。 例えば、Aさんが自分の環境で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 セルの中から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 アクティブセルを指定したセルにコピーする †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 アクティブセルのデータを横方向のセルにコピーする †' ここでは、横方向に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セル毎にセルをコピーする †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 'アクティブセルから上の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行挿入する †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 アクティブセルの行のカラー設定を変更する †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
|