| |
>現在はシート1で数字だけにして､setで列を配列変数にセットして､
>Transposeで行列変換して移動している形でした｡
では、シート1上でデータの削除を行って善いのですね？
こんなで如何でしょう
Option Explicit
Public Sub Sample3()
Dim i As Long
Dim lngCount As Long
Dim lngRows As Long
Dim lngColumns As Long
Dim rngList As Range
Dim rngResult As Range
Dim vntData As Variant
Dim lngDelete() As Long
Dim strProm As String
'結果を出力する位置すぉ指定
Set rngResult = Worksheets("Sheet2").Cells(1, 1)
'画面更新を停止
Application.ScreenUpdating = False
With Worksheets("Sheet1").UsedRange
'◆Listの先頭セル位置を基準とする
Set rngList = .Cells(1, 1)
'行列数の取得
lngRows = .Rows.Count
lngColumns = .Columns.Count
If .Count = 1 Then
strProm = "データが有りません"
GoTo Wayout
End If
'先頭列の値を配列に取得
vntData = rngList.Resize(lngRows + 1).Value
'削除Flag用の配列を確保
ReDim lngDelete(1 To lngRows, 1 To 1)
End With
With rngList
'先頭列の値が文字列なら削除Flagに1を立てる
For i = 1 To lngRows
'先頭列の値が空白で若しくは、数値で無いなら
If vntData(i, 1) = "" Or (Not IsNumeric(vntData(i, 1))) Then
'Flagに1を立てる
lngDelete(i, 1) = 1
'削除行数をカウント
lngCount = lngCount + 1
End If
Next i
If lngCount > 0 Then
'FlagをL列に出力
.Offset(, lngColumns).Resize(lngRows) = lngDelete
'削除行を最終行に集める為、L列をKeyとして整列
.Resize(lngRows, lngColumns + 1).Sort _
Key1:=.Offset(, lngColumns), Order1:=xlAscending, _
Header:=xlNo, OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom, SortMethod:=xlStroke
'行を削除
.Offset(lngRows - lngCount).Resize(lngCount).EntireRow.Delete
'Keyを削除
.Offset(, lngColumns).EntireColumn.Delete
End If
End With
With rngResult
If rngList.Resize(lngRows - lngCount, lngColumns).Count > 1 Then
'削除処理を行ったデータをTransposeしてSheet2に貼り付け
.Resize(lngColumns, lngRows - lngCount).Value _
= Application.WorksheetFunction.Transpose(rngList.Resize(lngRows _
- lngCount, lngColumns).Value)
End If
End With
strProm = "処理が完了しました"
Wayout:
'画面更新を再開
Application.ScreenUpdating = True
Set rngList = Nothing
Set rngResult = Nothing
MsgBox strProm, vbInformation
End Sub
|
|
Hirofumi
- 08/10/6(月) 18:52 -
