VBAを用いて指定した範囲内のデータをx, y軸に対して線対象なデータをプロットするマクロを作成しました。
私はVBAを触ったことがなかったので、ネットの情報を見ながら試行錯誤で組んだのですが、期待する動きはするものの動作が重く感じます。
どうすればより早く動作するマクロにできますでしょうか?
また、エクセル上ではなくクリップボードに線対象なデータを持たせることは可能でしょうか?
期待する動作は、以下の図上、左側の3*3マトリクスを選択して
マクロを走らせると右側のデータがプロットされる動きです。
y軸反転の場合 a b c c b a d e f -> f e d g i i g
VBA
1Sub MirrorY() 2' 3' MirrorY Macro 4' 5 6 If TypeName(Selection) = "Range" Then 7 Application.ScreenUpdating = False 8 Application.Calculation = xlCalculationManual 9 10 Dim i, j, srcStart, srcEnd, srcStartRow, srcEndRow, dstStart, limit, hight As Integer 11 Dim srcArea, dstArea As Range 12 13 Set srcArea = Selection 14 limit = srcArea.Columns.Count 15 hight = srcArea.Rows.Count 16 srcEndRow = srcArea.Cells(srcArea.Count).Row 17 srcStartRow = srcArea.Row 18 19 Set dstArea = srcArea.Offset(, limit) 20 If WorksheetFunction.CountA(dstArea) = 0 Then 21 22 srcStart = srcArea.Column 23 srcEnd = srcStart + limit 24 dstStart = dstArea.Column 25 26 For i = 0 To limit 27 Range(Cells(srcStartRow, srcEnd - i), Cells(srcEndRow, srcEnd - i)).Select 28 Application.CutCopyMode = False 29 Selection.Copy 30 Cells(srcStartRow, dstStart + i).Select 31 ActiveSheet.Paste 32 Next i 33 Else 34 MsgBox "書込み範囲が空白ではありません" 35 End If 36 Application.ScreenUpdating = True 37 Application.Calculation = xlCalculationAutomatic 38 End If 39End Sub
Sub MirrorX() ' ' MirrorX Macro ' ' If TypeName(Selection) = "Range" Then Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Dim i, j, srcStart, srcEnd, srcStartCol, srcEndCol, dstStart, limit, width As Integer Dim srcArea, dstArea As Range Set srcArea = Selection limit = srcArea.Rows.Count width = srcArea.Columns.Count srcEndCol = srcArea.Cells(srcArea.Count).Column srcStartCol = srcArea.Column Set dstArea = srcArea.Offset(limit) If WorksheetFunction.CountA(dstArea) = 0 Then srcStart = srcArea.Row srcEnd = srcStart + limit dstStart = dstArea.Row For i = 0 To limit Range(Cells(srcEnd - i, srcStartCol), Cells(srcEnd - i, srcEndCol)).Select Application.CutCopyMode = False Selection.Copy Cells(dstStart + i, srcStartCol).Select ActiveSheet.Paste Next i Else MsgBox "書込み範囲が空白ではありません" End If Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic End If End Sub
回答2件
あなたの回答
tips
プレビュー
バッドをするには、ログインかつ
こちらの条件を満たす必要があります。
2017/01/13 10:11