Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


73142 / 76732 ←次へ | 前へ→

【8073】Re:複数のデーターを1つの表に
回答  しのしの  - 03/9/29(月) 13:47 -

引用なし
パスワード
    >>カオルさんご提示の例は、その”計算シート”のA列からR列に含まれている
>>データを指すのではないですか?
>
>>>違います。Y2〜AA2、AG2〜AI2、AO2〜AQ2、AW2〜AY2、BE2〜BG2に入ってる値を並べたものです。
>
>>解決策をさがしていきましょう。
>>その小項目のうち、パレット数は空白になることがあっても、
>>その他の2つには必ず、値がはいる。すなわち、部数、本数が空白のときは、
>>データが最後まで来た、と判断して構わないのでしょうか?
>>>>そのとうりです。

上記を自分なりに解釈してコードにしてみました。

この計算シートを保存しているブックに
標準モジュールシートとクラスモジュールを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
2 hits

【7920】複数のデーターを1つの表に カオル 03/9/23(火) 22:16 質問
【7932】Re:複数のデーターを1つの表に しのしの 03/9/24(水) 14:37 発言
【7948】Re:複数のデーターを1つの表に カオル 03/9/25(木) 0:50 発言
【8009】Re:複数のデーターを1つの表に しのしの 03/9/26(金) 14:01 発言
【8036】Re:複数のデーターを1つの表に カオル 03/9/27(土) 2:58 質問
【8038】Re:複数のデーターを1つの表に しのしの 03/9/27(土) 12:03 発言
【8051】Re:複数のデーターを1つの表に カオル 03/9/28(日) 13:40 質問
【8073】Re:複数のデーターを1つの表に しのしの 03/9/29(月) 13:47 回答
【8188】Re:複数のデーターを1つの表に カオル 03/10/3(金) 0:51 お礼

73142 / 76732 ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free