0

vba を使用して Excel マクロをプログラミングしたことはありません。フィルタリングが必要なデータが大量にあるため、Excel マクロで解決できる問題に直面しています。簡単です例で説明します

元のテーブル:

name1 123456789
name2 234567783 3456677889
name3 213123123
name4 123451231 123412312 1231223523

マクロを実行する必要があるのは、3 列目または 4 列目、またはその両方でデータを見つけたときです。新しい行を挿入し、列の名前と 3 列目の数値で埋めて、データがそのようになるようにします。

どのようにテーブルが想定されているか:

name1 123456789 (stays the same no data in column 3 or 4)
name2 234567783 (removes the third column data and put it in a new row)
name2 3456677889 (keeping the name that the data had)
name3 213123123 (stays the same no data in column 3 or 4)
name4 123451231 (removes the third column data and forth column data and put it in new rows)
name4 123412312 
name4 1231223523

私はスクリプトで作業しようとしましたが、これまでに到達したものは次のとおりです。

Sub test()
Dim cell As Range
For Each cell In Range("d2:d40")
    If Not IsEmpty(cell.Value) Then
        MyAddress = ActiveCell.Row
        Rows(MyAddress).Select
        Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
        Range("a" & cell.Row).Select
        Selection.Copy
        Range("a" & cell.Row + 1).Select
        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
            :=False, Transpose:=False
        Range("b" & "cell.Row").Select
        Application.CutCopyMode = False
        Selection.Copy
        Range("B" & cell.Row).Select
        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
            :=False, Transpose:=False
    End If
Next cell
End Sub

このマクロを実行した後、Excel がフリーズします。

4

1 に答える 1

0

コードの主な問題はこの行でした。これは範囲を拡大し続けたため、最後に到達することはなく、「フリーズ」しました

Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove

このコードを見てください。データの一番下から始まり、拡大し続ける範囲の問題を回避しています。データは「A1」から始まると想定しています。

Sub test2()

Dim r As Range, x As Long, y As Long, Cnt As Long

Application.ScreenUpdating = False '**faster

With ActiveSheet 'specify actual sheet
    Cnt = .Cells(.Rows.CountLarge, 1).End(xlUp).Row 'last non blank cell in column A
'   rows loop
    For y = Cnt To 1 Step -1 'start at last row and work up
        Set r = .Range(.Cells(y, 1), .Cells(y, .Columns.Count).End(xlToLeft)) 'current row
'       loop thru cells in current row

        If Not IsEmpty(r(1)) Then '** skip empty cell

          For x = r.Cells.Count To 3 Step -1
             r.Offset(1).EntireRow.Insert Shift:=xlDown 'insert row
             r(x).Cut r(2).Offset(1) 'number to column B
             r(1).Offset(1).Value = r(1).Value 'name to column A
         Next x
       End If '**
    Next y
End With

Application.ScreenUpdating = True '**

End Sub
于 2013-11-06T08:32:56.627 に答える