| |
▼はる さん：
こんばんは
とりあえずサンプルを２つ。
Sample1は、わかりやすいのではと思います。
Sample2は高速版です。コートにコメントをつけてありますが、わからなかったら質問してください。
なお、そちらでアップされたコードについては、今からみてみますね。
Sub Sample1()
Dim j As Long
Dim x As Long
Application.ScreenUpdating = False
With Sheets("Sheet1")
x = .Cells(2, .Columns.Count).End(xlToLeft).Column 'リストのタイトル行の最終列番号
For j = x To 1 Step -1 '最終列から逆に、各列をチェック
'その列のセルで値があるセルがタイトル行のみなら列削除
If WorksheetFunction.CountA(.Columns(j)) = 1 Then Columns(j).Delete
Next
End With
Application.ScreenUpdating = True
End Sub
Sub Sample2()
Dim w() As Variant
Dim k As Long
Dim i As Long
Dim j As Long
Dim x As Long
Dim y As Long
Dim wk As Variant
Application.ScreenUpdating = False
With Sheets("Sheet1")
x = .Cells(2, .Columns.Count).End(xlToLeft).Column 'リストのタイトル行の最終列番号
With .UsedRange
y = .Cells(.Count).Row 'リストの最終行番号
End With
ReDim w(1 To y, 1 To x) '現在のシートイメージが収まる縦横の配列
For j = 1 To x
If WorksheetFunction.CountA(.Columns(j)) > 1 Then
'もし、タイトル行以外にも値があればその列を配列に左詰でセット
k = k + 1
For i = 1 To y
w(i, k) = .Cells(i, j)
Next
End If
Next
.Range("A1").Resize(y, x).Value = w 'できあがった配列を一挙にシートに落とし込む
End With
Application.ScreenUpdating = True
End Sub
|
|
UO3
- 12/3/16(金) 19:53 -
