>(1)グラフの二行目をすべて削除し、上詰めしたいです。
>※9,11,13~と削除していきたい。
という条件から考えますと、
>9列目から、奇数の列を削除する
というのは「9行目から、奇数の行を削除する」の間違いではないでしょうか?
同様に
>☆1項目2列使っている表を1項目1列にしたい。
というのは「1項目2行使っている表を1項目1行にしたい。」の間違いではないでしょうか?
同様に
>(2)このシートの表の終わりは15列目になっていますが、他のシートは25列で終わりだったりとばらばらです。
というのは「(2)このシートの表の終わりは15行目になっていますが、他のシートは25行で終わりだったりとばらばらです。」の間違いではないでしょうか?
それで、
>(3)列を削除した際、表の下線が消えると思います。消した線も復活させたいです。
の条件が非常に面倒で、この条件さえなければ簡単なのですが、必要だと仰るのであれば致し方ありません。
(3)の条件に関しては十分に満たしているとは言い難い(通常は下罫線が消えないのですが、下罫線の色等の設定によっては消えてしまう場合がある)のですが、次の様なマクロは如何でしょうか?
Sub QNo8978664_特定の位置から奇数の行を削除する方法()
Dim FirstRow As Long, LastRow As Long, FirstColumn As Integer _
, myWidth As Integer, i As Long, c As Range, RefColumn As String
Application.ScreenUpdating = False 'モニター表示の更新OFF
Application.Calculation = xlCalculationManual '手動計算モードに切り替え
RefColumn = "A" '罫線で囲まれているか否かを判定する基準にする列
FirstRow = 9 '削除する行の中で一番上の行
With ActiveSheet.UsedRange '使用されている全てのセルを含んでいるセル範囲
LastRow = .Row + .RowS.Count - 1 '使用されている行の中の最終行
FirstColumn = .Column '使用されている列の中の最終列
myWidth = .Columns.Count '使用されている列の数
End With
'「削除する行の中で一番上の行」として設定されている行以下に、使用済みのセルが無ければ処理を中止
If LastRow < FirstRow - 1 Then
MsgBox RefColumn & "列の" & FirstRow & "行目以下に表が見つかりません。" _
& vbCrLf & "マクロを終了します。", vbExclamation, "表無し"
Exit Sub
End If
'「使用されている行の中の最終行」と「削除する行の中で一番上の行」の差が奇数行だった場合には最終行を1つ下の行とする
LastRow = LastRow - WorksheetFunction.IsOdd(LastRow - FirstRow)
For i = LastRow To FirstRow Step -2 '1行おきに処理を行う
With Cells(i, FirstColumn).Resize(, myWidth) '処理の対象とするセル範囲を設定
Set c = Range(RefColumn & i) '行削除時に下罫線が消えてしまうのか否かの判定を行う際の基準となるセルを設定
If c.Offset(1).Borders(xlEdgeBottom).LineStyle = xlLineStyleNone _
And c.Borders(xlEdgeBottom).LineStyle <> xlLineStyleNone Then 'セルcに下罫線があり、その1つ下のセルには下罫線が無い場合
For Each c In .Offset() '横1列のセル範囲に含まれているセル1つごとに繰り返し処理
c.Offset(-1).Borders(xlEdgeBottom).LineStyle = c.Borders(xlEdgeBottom).LineStyle '削除予定の行のセルに対して、1つ下のセルの下罫線の線種の設定をコピー
c.Offset(-1).Borders(xlEdgeBottom).ColorIndex = c.Borders(xlEdgeBottom).ColorIndex '削除予定の行のセルに対して、1つ下のセルの下罫線の線色の設定をコピー
c.Offset(-1).Borders(xlEdgeBottom).TintAndShade = c.Borders(xlEdgeBottom).TintAndShade '削除予定の行のセルに対して、1つ下のセルの下罫線のテーマの色の設定をコピー
c.Offset(-1).Borders(xlEdgeBottom).Weight = c.Borders(xlEdgeBottom).Weight '削除予定の行のセルに対して、1つ下のセルの下罫線太さの設定をコピー
Next c
End If
.Delete Shift:=xlShiftUp 'セル範囲を削除し、その下の行を繰り上げる
End With
Next i
Application.Calculation = xlCalculationAutomatic '自動計算モードON
Application.ScreenUpdating = True 'モニター表示の更新ON
End Sub
お礼
早速の回答ありがとうございました。 無事処理ができましたので、お礼申し上げます。