callmekohei's blog

はうあうあ はうあうあ

定時でカエルVBA - 2019-02-14 Excelのワークシートに行を挿入する、行を削除する

Summary

文字列で特定した任意のセルに対して行を挿入するもしくは行を削除する

動作の概要

こんなかんじ

使いどころ

帳票で枠が足りなくなった時に行挿入、枠の余白がありすぎる時に行削除をする

枠が500個とかの時に本当に役立つ(これで20分とか平気で浮くのですごく助かる)

コードの概要

1: 挿入したい行を文字列で特定する
2: 行を挿入する

下記のコードは大体の感じで読んでいただければ・・・

1: 挿入したい行を文字列で特定する

まずRangeValueを配列に持ってきます

''' こんなかんじ
Dim ws As Worksheet: Set ws = ThisWorkbook.Worksheets("foo")
Dim arr As Variant: arr = ws.Range("B3:B10").Value

その配列に対して正規表現でフィルタリングします

'''こんな感じ
For Each inArr In GetVal(rng, isVertical)
    Dim i As Long
    For i = 1 To ArrLen(inArr)
        If ArrLen(ReMatch(inArr(i), ptrnFind)) > 0 Then arrx.AddObj ws.Cells(rng.offset(i - 1).Row, rng.Column)
    Next i
Next inArr

これで特定の行のにあるRangeを取得できました!

2: 行を挿入する

行を挿入するにはRangeInsertメソッドを使用します

''' 2行目に1行追加する
Range("A2:A2").Insert

また複数の行を挿入する場合はUnionInsertメソッドを使用します

''' 3行目と5行目に同時に1行追加する
Union(Range("A3"),Range("A5")).EntireRow.Insert

これをふまえて先ほど取得した文字列にて特定したRangeUnionにします

''' @param arr as Vaiant(Of Array(Of Range)
''' @return Range
Public Function UnionRanges(ByVal arr As Variant) As Range
    Dim rng As Variant, uRng As Range
    For Each rng In arr
        If uRng Is Nothing Then
            Set uRng = rng
        Else
            Set uRng = Union(uRng, rng)
        End If
    Next rng
    Set UnionRanges = uRng
End Function

最終的にはこんな感じの関数で使いやすくしました

''' @param rng As Rang
''' @param ptrnFind As String
''' @param times As Long
''' @param offsetRow As Long
''' @param offsetColumn As Long
Public Sub InsertRows(ByVal rng As Range, ByVal ptrnFind As String _
    , Optional ByVal times As Long = 1, Optional ByVal offsetRow As Long = 0, Optional ByVal offsetColumn As Long = 0)
    Dim i As Long
    For i = 1 To times
        If offsetRow = 0 And offsetColumn = 0 Then
            UnionRanges(RegexRanges(rng, ptrnFind)).EntireRow.Insert
        Else
            UnionRanges(offsetRanges(RegexRanges(rng, ptrnFind), offsetRow, offsetColumn)).EntireRow.Insert
        End If
    Next i
End Sub

たとえばこんな感じで使います

Sub Sample_InsertRows()
    Dim ws As Worksheet: Set ws = ThisWorkbook.Worksheets("bbb")
    InsertRows xlUpRange(ws.Range("b6")), "\d-\d.*", 3
End Sub

Sub Sample_DeleteRows()
    Dim ws As Worksheet: Set ws = ThisWorkbook.Worksheets("bbb")
    DeleteRows xlUpRange(ws.Range("b6")), "\d-\d.*", 3, -1
End Sub

deleteメソッドに関しては、特定の文字列の行以外に、その上5行消したいとかいうのがあるのでOffsetで指定できるようにもしてます

感想

VBAをその場で書くのは本当に難しい・・・(自分のVBA力がないはもちろんですが)

現在、IT派遣バイトをやってるのですが、業務中に10分、20分で書ける内容じゃなかった・・・

定時でカエルVBA - 2019-01-22 自分的なトランスポーズ関数 書いたった

Summary

最近書いた関数をさらしてみるぽよ

こんな感じ

''' @param arr2D As Variant(Of Array(Of T, T))
''' @return As Variant(Of Array(Of T, T))
Public Function ArrTranspose(ByVal arr2D As Variant) As Variant

    If Not IsArray(arr2D) Then Err.Raise 13
    If Not ArrRank(arr2D) = 2 Then Err.Raise 13

    Dim lb1 As Long: lb1 = LBound(arr2D, 2)
    Dim ub1 As Long: ub1 = UBound(arr2D, 2)
    Dim lb2 As Long: lb2 = LBound(arr2D, 1)
    Dim ub2 As Long: ub2 = UBound(arr2D, 1)

    Dim tmpArr2D() As Variant
    ReDim tmpArr2D(lb1 To ub1, lb2 To ub2)

    Dim ix1 As Long, ix2 As Long
    For ix1 = lb1 To ub1
        For ix2 = lb2 To ub2
            If IsObject(arr2D(ix2, ix1)) Then
                Set tmpArr2D(ix1, ix2) = arr2D(ix2, ix1)
            Else
                Let tmpArr2D(ix1, ix2) = arr2D(ix2, ix1)
            End If
        Next ix2
    Next ix1

    ArrTranspose = tmpArr2D

End Function

これはなに?

配列の中身を交換する関数ですっ

ワークシートのTranspose関数とほぼ同じです

ちがいはnullでもオーケーというところと

メモリの許す限りやってくれるところ(だと思う)

どんなところで使うの?

たとえばADODBGetRows()とかで、はうあうあな感じの配列がかえってくるのでこれで90度回してあげるといい感じになります

' こんなかんじ
ArrTranspose(rcds.GetRows())))

こんなところで :-)

定時でカエルVBA - 2015-08-27

Summary

VBA (小ネタ)マリオをイミディエイトウィンドウにかいてみる! ちょっとしたネタですよ、というはなし

エクセルシートになんとなく描いてみて・・・

f:id:callmekohei00:20190121220432p:plain

デバッグウインドウ(イミディエイト ウインドウ)に出力する

f:id:callmekohei00:20190121220421p:plain

サンプルコード

''' draw mario
Sub Sample20150827()
    
    Dim inArr As Variant, s As Variant, str As String
    For Each inArr In Arr2DToJagArr(Worksheets("test").Range("A1:L16").Value)
        For Each s In inArr: str = IIf(s = 1, str & "●", str & " "): Next s
        Debug.Print str: str = ""
    Next inArr

End Sub

サンプルコードその2

Sub Sample20190211()
    
    ''' draw mario
    Dim inArr As Variant, s As Variant, str As String
    For Each inArr In Arr2DToJagArr(Worksheets("test").Range("A1:L16").Value)
        For Each s In inArr: str = IIf(s = 1, str & "●", str & " "): Next s
        Debug.Print str: str = ""
    Next inArr

End Sub