削除を繰り返す？

VBA 知恵袋

知恵袋で回答したもので、奇数行６列・偶数行２列からなるデータが何千行とあるシートを、奇数行のデータを偶数行の右に転記し、奇数行を削除するにはどうしたらいいかって質問でした。

そんなに削除したくないよね？

遅くなるし・・・

なので、書き換える方法を回答。

 

Sub OneCase()
    Dim i As Long, j As Long, lastRow As Long
    Dim dataArray() As Variant
    
    lastRow = Cells(Rows.Count, "A").End(xlUp).Row
    
    ReDim dataArray(1 To lastRow \ 2, 1 To 10)
    
    For i = 2 To lastRow Step 2
        For j = 1 To 2
            dataArray(i \ 2, j) = Cells(i, j).Value
        Next j
        
        For j = 3 To UBound(dataArray, 2)
            dataArray(i \ 2, j) = Cells(i - 1, j - 2).Value
        Next j
    Next i
    
    Cells.Clear
    
    Range("G1:H" & UBound(dataArray)).NumberFormatLocal = "0.00%"
    
    Range("A1").Resize(UBound(dataArray), UBound(dataArray, 2)) = dataArray
End Sub

 

 

コードの倉庫に

VBA 知恵袋 EXCEL・ACCESS

私は知恵袋で回答をよく投稿するのですが、そのコードは一応保存してるんです。

それが結構貯まって来て整理出来なくなったので、ここに上げておいてPCからは削除しようかと思います。

公開しておけば誰かの何かの役に立つかもしれないしね。＾＾

 

これは各行で列数の違うデータをA列に縦１列で表示するにはどうしたらいいかって質問に回答した時の物です。

 

Sub OneCase()
    Dim rng As Range
    Dim ws As Worksheet
    Dim i As Long, j As Long
    
    Set ws = Worksheets("Sheet1")
    
    With Worksheets("Sheet2")
        For i = 1 To .Cells(Rows.Count, "A").End(xlUp).Row
            Set rng = .Range(.Cells(i, "A"), .Cells(i, .Cells(i, Columns.Count).End(xlToLeft).Column))
            
            If ws.Range("A1").Value <> "" Then j = 2
            ws.Cells(Rows.Count, "A").End(xlUp).Offset(j).Resize(rng.Count) = Application.Transpose(rng)
        Next i
    End With
End Sub

 

 

やっと入った。

EXCEL・ACCESS 質問箱

会社のMy PCにACCESSやっと入りました ^^

これで休みに自宅でコーディングしなくて済むなぁ。

もっとも、定時間内ではほとんど出来ませんが・・・

残業稼げて良いけどね。

今日も２時間やって来た。

 

で、帰宅してから知恵袋２件回答してこの時間。

もう、寝ます。

関数使うかメソッド使うか？

VBA 質問箱

今日、回答した物の中で気になった物がありました。

Application.InputBoxを使ってユーザーからの入力値を受け取った後の処理に関する物だったのですが、質問した方はTypeを指定していなかったんです。

なのに入力値が文字列扱いだと上手く行かないとか・・・・

InputBoxの関数とメソッドの違いはTypeに尽きると思うんですがねぇ。

 

ADOの方が早い

EXCEL・ACCESS VBA

何の話かと言うと、ACCESSのテーブルにレコードを追加する処理速度をSQLと比較した場合の事なんです。

前回作成したSQLをコレクションに入れて複数処理する自作関数を使用して２～３件のデータで追加処理のテストをしていたのですが、開始から終了までどうも一呼吸入る感じがして気になってたんです。

で、調べたらADOでAddNewメソッドが速いらしい。

試しに実装してみたらこちらの方が体感で格段に速く感じるんですね。

なので、AddNewを使用した方の自作関数に替えました。

何事も方法は１つじゃないって事ですね。 ^^

以下はその自作関数。

 

Function CompletionProcess(ByVal ws As Worksheet, ByVal tableName As String) As Boolean
    Dim i As Long
    
    DataBaseConnect
    
    On Error GoTo errorHandler
    
    Set adoRs = New ADODB.Recordset
    
    adoRs.Open tableName, adoCn, adOpenKeyset, adLockOptimistic
    
    adoCn.BeginTrans
    
    For i = 2 To ws.Cells(Rows.Count, "A").End(xlUp).Row
        If ws.Cells(i, "M").Value = 1 Then
            adoRs.AddNew Array(ws.Cells(1, "A").Value, ws.Cells(1, "B").Value, ws.Cells(1, "D").Value, _
                                ws.Cells(1, "F").Value, ws.Cells(1, "M").Value), _
                        Array(ws.Cells(i, "A").Value, ws.Cells(i, "B").Value, ws.Cells(i, "D").Value, _
                                ws.Cells(i, "F").Value, ws.Cells(i, "M").Value)
            
            adoRs.Update
        End If
    Next i
    
    adoCn.CommitTrans
    
    CompletionProcess = True
    DataBaseOut
    Exit Function
    
errorHandler:
    adoCn.RollbackTrans
    DataBaseOut
    CompletionProcess = False
    ErrorDisplay
End Function

直々のご依頼

う～んな出来事 VBA

本日、我が社の取締役営業本部長様より直々にシステム構築の依頼を受けました。

その内容は、

『営業部、いや、どこの誰がやっても自分がやるのと同様な見積書を作れる物を』

との事。

正直、断りたかった。

しかし、そこは悲しいかな只の平社員の身。

謹んでお受けする事にした。

ただし、1つだけ条件を付けた。

『部長の頭の中にある見積もりに関するあらゆる数値を曝け出して頂かないと実現出来ませんが、ご協力頂けますか？』と。

内心、（よく言ったぞ俺）と自我自賛♪

これを聞いた部長さん、ちょっと渋い顔したけど自分から言い出しただけに後には引けない様で、承諾してくれた。

断ってくれるのを期待してたのに・・・・

 

仕方ないので、目一杯良い物を作ってあげよう ^^

 

月曜から根掘り葉掘りインタビューするぞ～♪