なお、選択範囲を事前に調整するために以下のサブルーチンを使用しますので、使用される場合は以下のコードも合わせて使ってください。
found, known and done.: Excelの選択範囲をデータのある範囲に縮小する
http://foundknownanddone.blogspot.jp/2014/04/excel-shrink-selection.html#more
使用方法
セル範囲、行、列、シート全体を選択します。マクロを実行して、何行ごとに間引きたいのか指定します。
(なお、行や列を選択した場合、データの前後の空白セル部分は処理されません。)
コード
Sub combOutRow() Dim targetRange As Range Dim outputData() As Variant Dim spacing As Integer Dim maxRowCount As Long, minRowCount As Long Dim rowIndex As Long, columnIndex As Long Call shrinkSelectionRow Set targetRange = Selection spacing = CInt(Application.InputBox("Spacing = ", "combOutRow", 1, , , , , 1)) If spacing < 1 Then Exit Sub rowIndex = WorksheetFunction.Floor((targetRange.Rows.Count - 1) / spacing, 1) + 1 columnIndex = targetRange.Columns.Count ReDim outputData(1 To rowIndex, 1 To columnIndex) For i = 1 To targetRange.Rows.Count If (i - 1) Mod spacing = 0 Then For j = 1 To targetRange.Columns.Count outputData(1 + (i - 1) / spacing, j) = targetRange.Cells(i, j) Next End If Next With targetRange .ClearContents Range(.Rows(1), .Rows(rowIndex)) = outputData Range(.Rows(1), .Rows(rowIndex)).Select End With End Sub Sub combOutColumn() Dim targetRange As Range Dim outputData() As Variant Dim spacing As Integer Dim maxColumnCount As Long, minColumnCount As Long Dim rowIndex As Long, columnIndex As Long Call shrinkSelectionColumn Set targetRange = Selection spacing = CInt(Application.InputBox("Spacing = ", "combOutColumn", 1, , , , , 1)) If spacing < 1 Then Exit Sub rowIndex = targetRange.Rows.Count columnIndex = WorksheetFunction.Floor((targetRange.Columns.Count - 1) / spacing, 1) + 1 ReDim outputData(1 To rowIndex, 1 To columnIndex) For i = 1 To targetRange.Columns.Count If (i - 1) Mod spacing = 0 Then For j = 1 To targetRange.Rows.Count outputData(j, 1 + (i - 1) / spacing) = targetRange.Cells(j, i) Next End If Next With targetRange .ClearContents Range(.Columns(1), .Columns(columnIndex)) = outputData Range(.Columns(1), .Columns(columnIndex)).Select End With End Sub
No comments :
Post a Comment