| |
>>カオルさんご提示の例は、その”計算シート”のA列からR列に含まれている
>>データを指すのではないですか？
>
>>>違います。Ｙ２〜ＡＡ２、ＡＧ２〜ＡＩ２、ＡＯ２〜ＡＱ２、ＡＷ２〜ＡＹ２、ＢＥ２〜ＢＧ２に入ってる値を並べたものです。
>
>>解決策をさがしていきましょう。
>>その小項目のうち、パレット数は空白になることがあっても、
>>その他の２つには必ず、値がはいる。すなわち、部数、本数が空白のときは、
>>データが最後まで来た、と判断して構わないのでしょうか？
>>>>そのとうりです。
上記を自分なりに解釈してコードにしてみました。
この計算シートを保存しているブックに
標準モジュールシートとクラスモジュールを1つずつ用意してください。
#計算式からみて、ブックの容量もかなり大きそうなので、
#別ブックにコードを保存したほうがいいかもしれません。
#でもとりあえず、確認はこのままで。
シートの内容を書き換えるので、バックアップは撮って置いてくださいね。
【標準モジュールのコード】
Option Explicit
Sub TEST()
Dim rngDest As Excel.Range
Dim wshSource As Excel.Worksheet
Dim lngCount As Long
Dim cls1 As Class1
Dim lngWize As Long
Dim iCellAdd As Variant
Dim varSourceCellAdd As Variant
'もとデータとなるシートを設定してください。
'今は計算シートを設定しています
Set wshSource = ThisWorkbook.Worksheets("計算シート")
wshSource.Calculate
'大項目の先頭セルアドレスを指定してください。
'今は前の箱にあった値を設定しています。
varSourceCellAdd = Array("Y2", "AG2", "AO2", "AW2", "BE2")
'もとデータの行数をセットしてください。前の回答で60とあったので、
'60にしています
lngCount = 60
'もとデータは3列とします。
lngWize = 3
'1つの表にしたい左上先頭セルを指定してください。
'今は、仮に"品質管理表シート"の「T1」セルとしておきます。
Set rngDest = ThisWorkbook.Worksheets("品質管理表シート").Range("T1")
'必要なら、書き込む表のクリアをしてください。
'ここは仕様になかったので、単に列をクリアします。
'必要に応じて、書き直してください。
rngDest.Resize(, lngWize).EntireColumn.Clear
'フィルタークラスを生成します。
Set cls1 = New Class1
For Each iCellAdd In varSourceCellAdd
Call cls1.setValues( _
wshSource.Range(CStr(iCellAdd)).Resize(lngCount, lngWize))
If cls1.SpecalFilter = True Then
Call cls1.Up(rngDest)
Set rngDest = rngDest.Offset(cls1.RowsCount)
End If
Next iCellAdd
Set cls1 = Nothing
Set rngDest = Nothing
Exit Sub
End Sub
【クラスのコード】クラス名はCLASS1のままにしてあります。
' Excel Cell範囲Value（二次元配列）を取り扱うクラス
'結合セルには考慮しない
'二次元配列はセルから取得するので、配列添字開始は1として取り扱っている
Option Explicit
Option Base 0
Option Compare Binary
Private mArray As Variant
Private Sub Class_Terminate()
On Error Resume Next
Erase mArray
End Sub
Public Property Get RowsCount() As Long
If IsArray(mArray) = False Then
RowsCount = 0
Exit Property
Else
RowsCount = UBound(mArray, 1)
End If
End Property
'取り扱うセルの値を取得する
Public Sub setValues(ByRef rRng As Excel.Range)
If (rRng Is Nothing) = True Then
mArray = Empty
Else
mArray = rRng.value
End If
End Sub
Public Function SpecalFilter() As Boolean
On Error GoTo HandleErr
Dim irow As Long
Dim icol As Long
Dim lngNewElem As Long
Dim TmpArray() As Variant
If IsArray(mArray) = False Then
SpecalFilter = False
Exit Function
End If
lngNewElem = 0
For irow = 1 To UBound(mArray, 1)
'ここで、2列目と、3列目が空白であるかのチェックをしています。
'ご希望の分岐ができているか確認してみてください。
If mArray(irow, 2) = "" And mArray(irow, 3) = "" Then
Exit For
Else
lngNewElem = lngNewElem + 1
End If
Next irow
If lngNewElem = 0 Then
mArray = Empty
SpecalFilter = False
Exit Function
End If
ReDim TmpArray(1 To lngNewElem, 1 To UBound(mArray, 2))
For irow = 1 To lngNewElem
For icol = 1 To UBound(TmpArray, 2)
TmpArray(irow, icol) = mArray(irow, icol)
Next icol
Next irow
mArray = TmpArray
Erase TmpArray
SpecalFilter = True
Exit Function
HandleErr:
MsgBox "エラーが発生しました。フィルタできませんでした。" & Err.Description
Resume EndProc
EndProc:
On Error Resume Next
Erase TmpArray
SpecalFilter = False
End Function
'値をセルに上書きする
Public Sub Up(ByRef rRange As Excel.Range)
If IsArray(mArray) = False Then
Exit Sub
End If
With rRange.Resize(UBound(mArray, 1), UBound(mArray, 2))
.value = mArray
End With
End Sub
|
|
しのしの
- 03/9/29(月) 13:47 -
