Excel VBA質問箱 IV

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

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


4048 / 13644 ツリー ←次へ | 前へ→

【58158】データの並べ替えについて 夜勤担当 08/10/6(月) 19:43 質問[未読]
【58159】Re:データの並べ替えについて kanabun 08/10/6(月) 20:30 発言[未読]
【58162】Re:データの並べ替えについて 夜勤担当 08/10/6(月) 22:10 お礼[未読]
【58161】Re:データの並べ替えについて Hirofumi 08/10/6(月) 21:10 回答[未読]
【58163】Re:データの並べ替えについて 夜勤担当 08/10/6(月) 22:14 質問[未読]
【58178】Re:データの並べ替えについて Hirofumi 08/10/7(火) 18:20 発言[未読]
【58181】Re:データの並べ替えについて Hirofumi 08/10/7(火) 18:33 回答[未読]
【58212】Re:データの並べ替えについて 夜勤担当 08/10/11(土) 21:54 質問[未読]
【58218】Re:データの並べ替えについて Hirofumi 08/10/12(日) 4:58 回答[未読]
【58228】Re:データの並べ替えについて 夜勤担当 08/10/12(日) 21:21 お礼[未読]
【58668】Re:データの並べ替えについて 夜勤担当 08/11/4(火) 14:00 質問[未読]
【58670】Re:データの並べ替えについて kanabun 08/11/4(火) 14:22 発言[未読]
【58165】Re:データの並べ替えについて kanabun 08/10/7(火) 9:36 発言[未読]
【58210】Re:データの並べ替えについて 夜勤担当 08/10/11(土) 21:46 質問[未読]

【58158】データの並べ替えについて
質問  夜勤担当  - 08/10/6(月) 19:43 -

引用なし
パスワード
   こんばんは
 以下のデータ整理をするのに、ExcelVBAの力で、ぜひ問題解決方法をご指導下さい。

元データ(シートA)
  A     B     C     D     E     F      G
1  CD    NAME    10     20     30    40     50
2
3  A01    AAAA    *           +     *
4  B01    BBBB         *                +
5  C01    CCCC               +           *



結果(シートB)
  A     B     C     D
1  CD    NAME    PD     MB
2  A01    AAAA    10     * 
3  A01    AAAA    30     +
4  A01    AAAA    40     *
5  B01    BBBB    20     *
6  B01    BBBB    50     +
7  C01    CCCC    30     +
8  C01    CCCC    50     *



【58159】Re:データの並べ替えについて
発言  kanabun  - 08/10/6(月) 20:30 -

引用なし
パスワード
   ▼夜勤担当 さん:

説明なしですが、
参考にどうぞ。

Sub Try1()
 Dim 行見出し As Range
 Dim 列見出し As Range
 Dim 元データ As Range
 Dim 結果()
 Dim data
 Dim dataCount As Long
 Dim i As Long, j As Long, k As Long
 
 With Worksheets("元データ")
   Set 行見出し = .Range("A3", .Range("A65536").End(xlUp)).Resize(, 2)
   Set 列見出し = .Range("C1", .Range("IV1").End(xlToLeft))
   Set 元データ = 行見出し.Offset(, 2).Resize(, 列見出し.Count)
   dataCount = WorksheetFunction.CountA(元データ)
   ReDim 結果(dataCount, 1 To 4)
   結果(0, 1) = "CD"
   結果(0, 2) = "NAME"
   結果(0, 3) = "PD"
   結果(0, 4) = "MB"
   With 元データ             '元データ範囲を
     For i = 1 To 行見出し.Rows.Count  '行方向にループ
       For j = 1 To 列見出し.Count    '列方向に繰り返す
         data = .Item(i, j).Value    '対象セルに
         If Not IsEmpty(data) Then    'データがあるとき
           k = k + 1          '転記用配列の行番号を更新
           結果(k, 1) = 行見出し(i, 1).Value '配列にデータを
           結果(k, 2) = 行見出し(i, 2).Value '書き出す
           結果(k, 3) = 列見出し(1, j).Value
           結果(k, 4) = data
         End If
       Next
     Next
   End With
 End With
 
 With Worksheets("結果")        '結果シートに結果の配列を書き出す
   .UsedRange.ClearContents
   .Range("A1").Resize(k + 1, 4).Value = 結果
 End With
End Sub

【58161】Re:データの並べ替えについて
回答  Hirofumi  - 08/10/6(月) 21:10 -

引用なし
パスワード
   似たような物だけど

Option Explicit

Public Sub Sample()

  '◆Listデータ列数(A列〜G列)
  Const clngColumns As Long = 7
  'PDの始まる列位置を指定(基準位置からの列Offsetで指定:C列)
  Const clngPD As Long = 2
  
  Dim i As Long
  Dim j As Long
  Dim lngRows As Long
  Dim rngList As Range
  Dim rngResult As Range
  Dim vntData As Variant
  Dim vntResult As Variant
  Dim lngWrite As Long
  Dim vntPD As Variant
  Dim strProm As String

  '◆Listの先頭セル位置を基準とする(A列の列見出しのセル位置)
  Set rngList = Worksheets("シートA").Cells(1, "A")

  '◆結果の先頭セル位置を基準とする(A列の列見出しのセル位置)
  Set rngResult = Worksheets("シートB").Cells(1, "A")
  
  With rngList
    '行数の取得
    lngRows = .Offset(Rows.Count - .Row).End(xlUp).Row - .Row
    If lngRows <= 0 Then
      strProm = "データが有りません"
      GoTo Wayout
    End If
    lngRows = lngRows - 1
    'PDを配列に取得
    vntPD = .Resize(, clngColumns).Value
    '基準位置を1つ下に変更
    Set rngList = .Offset(1)
  End With
  
  '結果用配列を確保
  ReDim vntResult(1 To 4)
  
  '画面更新を停止
  Application.ScreenUpdating = False
  
  For i = 1 To lngRows
    'Listから1行分を配列に取得
    vntData = rngList.Offset(i).Resize(, clngColumns).Value
    '先頭2列を結果配列に転記
    For j = 1 To 2
      vntResult(j) = vntData(1, j)
    Next j
    '3列目から後ろ見て行く
    For j = clngPD + 1 To clngColumns
      If vntData(1, j) <> "" Then
        'PD、MBを転記
        vntResult(3) = vntPD(1, j)
        vntResult(4) = vntData(1, j)
        '"シートB"に転記
        lngWrite = lngWrite + 1
        rngResult.Offset(lngWrite).Resize(, UBound(vntResult)).Value = vntResult
      End If
    Next j
  Next i
  
  strProm = "処理が完了しました"
   
Wayout:

  '画面更新を再開
  Application.ScreenUpdating = True
  
  Set rngList = Nothing
  Set rngResult = Nothing
   
  MsgBox strProm, vbInformation
     
End Sub

【58162】Re:データの並べ替えについて
お礼  夜勤担当  - 08/10/6(月) 22:10 -

引用なし
パスワード
   こんばんは、ご回答をいただき、ありがとうございました。
無事に計算できましたので、
ご報告します。

【58163】Re:データの並べ替えについて
質問  夜勤担当  - 08/10/6(月) 22:14 -

引用なし
パスワード
   こんばんは!
 正しく計算ができましたが、タイトルの表示がでていません。
再度点検しますので、のちほど報告いたします。

【58165】Re:データの並べ替えについて
発言  kanabun  - 08/10/7(火) 9:36 -

引用なし
パスワード
   ▼夜勤担当 さん:

> 正しく計算ができましたが、タイトルの表示がでていません。

おかしいですね?

こちらでは
「元データ」というシートに
>  A     B     C     D     E     F      G
>1  CD    NAME    10     20     30    40     50
>2
>3  A01    AAAA    *           +     *
>4  B01    BBBB         *                +
>5  C01    CCCC               +           *

こう打ち込んで、Try1() を走らせれば、

「結果」シートに
>  A     B     C     D
>1  CD    NAME    PD     MB
>2  A01    AAAA    10     * 
>3  A01    AAAA    30     +
>4  A01    AAAA    40     *
>5  B01    BBBB    20     *
>6  B01    BBBB    50     +
>7  C01    CCCC    30     +
>8  C01    CCCC    50     *

と、見出し付きで、表示されますが?

【58178】Re:データの並べ替えについて
発言  Hirofumi  - 08/10/7(火) 18:20 -

引用なし
パスワード
   シートBの列見出しは、特に書き込む様にしていません
もし、表示する方法が解らなければ修正しますが?

【58181】Re:データの並べ替えについて
回答  Hirofumi  - 08/10/7(火) 18:33 -

引用なし
パスワード
   列見出しを付けるついでに、「シートB」の結果を消去する様にしました

Option Explicit

Public Sub Sample2()

  '◆Listデータ列数(A列〜G列)
  Const clngColumns As Long = 7
  'PDの始まる列位置を指定(基準位置からの列Offsetで指定:C列)
  Const clngPD As Long = 2
  
  Dim i As Long
  Dim j As Long
  Dim lngRows As Long
  Dim rngList As Range
  Dim rngResult As Range
  Dim vntData As Variant
  Dim vntResult As Variant
  Dim lngWrite As Long
  Dim vntPD As Variant
  Dim strProm As String

  '◆Listの先頭セル位置を基準とする(A列の列見出しのセル位置)
  Set rngList = Worksheets("シートA").Cells(1, "A")

  '◆結果の先頭セル位置を基準とする(A列の列見出しのセル位置)
  Set rngResult = Worksheets("シートB").Cells(1, "A")
  
  With rngResult
    '行数の取得
    lngRows = .Offset(Rows.Count - .Row).End(xlUp).Row - .Row
    If lngRows > 0 Then
      .Parent.UsedRange.ClearContents
    End If
    .Resize(, 4).Value = Array("CD", "NAME", "PD", "MB")
  End With
  
  With rngList
    '行数の取得
    lngRows = .Offset(Rows.Count - .Row).End(xlUp).Row - .Row
    If lngRows <= 0 Then
      strProm = "データが有りません"
      GoTo Wayout
    End If
'    lngRows = lngRows - 1 '★削除(無くても構わなかった)
    'PDを配列に取得
    vntPD = .Resize(, clngColumns).Value
    '基準位置を1つ下に変更
'    Set rngList = .Offset(1) '★削除(無くても構わなかった)
  End With
  
  '結果用配列を確保
  ReDim vntResult(1 To 4)
  
  '画面更新を停止
  Application.ScreenUpdating = False
  
  For i = 1 To lngRows
    'Listから1行分を配列に取得
    vntData = rngList.Offset(i).Resize(, clngColumns).Value
    '先頭2列を結果配列に転記
    For j = 1 To 2
      vntResult(j) = vntData(1, j)
    Next j
    '3列目から後ろ見て行く
    For j = clngPD + 1 To clngColumns
      If vntData(1, j) <> "" Then
        'PD、MBを転記
        vntResult(3) = vntPD(1, j)
        vntResult(4) = vntData(1, j)
        '"シートB"に転記
        lngWrite = lngWrite + 1
        rngResult.Offset(lngWrite).Resize(, UBound(vntResult)).Value = vntResult
      End If
    Next j
  Next i
  
  strProm = "処理が完了しました"
   
Wayout:

  '画面更新を再開
  Application.ScreenUpdating = True
  
  Set rngList = Nothing
  Set rngResult = Nothing
   
  MsgBox strProm, vbInformation
     
End Sub

【58210】Re:データの並べ替えについて
質問  夜勤担当  - 08/10/11(土) 21:46 -

引用なし
パスワード
   kanabunさん
まったく問題なく動いています。
本当にありがとうございます。
パスワードでこのマクロの実行可否を制御する場合は、可能でしょうか?



【58212】Re:データの並べ替えについて
質問  夜勤担当  - 08/10/11(土) 21:54 -

引用なし
パスワード
   こんばんは!
返事遅くなり、すいません。
列見出しが表示されるようになりました。

>列見出しを付けるついでに、「シートB」の結果を消去する様にしました
              ↑シートBの結果を消去するようにしたとは
               どんな意味でしょうか?
>

【58218】Re:データの並べ替えについて
回答  Hirofumi  - 08/10/12(日) 4:58 -

引用なし
パスワード
   ▼夜勤担当 さん:
>こんばんは!
>返事遅くなり、すいません。
>列見出しが表示されるようになりました。
>
>>列見出しを付けるついでに、「シートB」の結果を消去する様にしました
>              ↑シートBの結果を消去するようにしたとは
>               どんな意味でしょうか?
>>

前のコードでは、「シートB」に対して何もしないで書き込みを行う状態でした
今回は、結果を書き込む前に「シートB」の使用範囲をClearContentsしている
と言う事です

【58228】Re:データの並べ替えについて
お礼  夜勤担当  - 08/10/12(日) 21:21 -

引用なし
パスワード
   わかりました。
シートBに複数回書き込んでしても、前のデータは残らなくなります。

【58668】Re:データの並べ替えについて
質問  夜勤担当  - 08/11/4(火) 14:00 -

引用なし
パスワード
   再質問です!
 よろしくお願いします。

 有効なデータであるならば、並べ替えの対象データとして取り扱いしますが、
双でない場合は、対象外データとして処理するには、どうやってコードを修正
しますか?
例、
有効データ:あ、い、う、え、お

【58670】Re:データの並べ替えについて
発言  kanabun  - 08/11/4(火) 14:22 -

引用なし
パスワード
   ▼夜勤担当 さん:
>再質問です!

> 有効なデータであるならば、並べ替えの対象データとして取り扱いしますが、
>双でない場合は、対象外データとして処理するには、どうやってコードを修正
>しますか?
>例、
>有効データ:あ、い、う、え、お

Sub Try1() を修正するなら、If文を追加して
こんなかな?

Sub Try2()
 Dim 行見出し As Range
 Dim 列見出し As Range
 Dim 元データ As Range
 Dim 結果()
 Dim data
 Dim dataCount As Long
 Dim i As Long, j As Long, k As Long
 
 
 With Worksheets("元データ")
   Set 行見出し = .Range("A3", .Range("A65536").End(xlUp)).Resize(, 2)
   Set 列見出し = .Range("C1", .Range("IV1").End(xlToLeft))
   Set 元データ = 行見出し.Offset(, 2).Resize(, 列見出し.Count)
   dataCount = WorksheetFunction.CountA(元データ)
   ReDim 結果(dataCount, 1 To 4)
   結果(0, 1) = "CD"
   結果(0, 2) = "NAME"
   結果(0, 3) = "PD"
   結果(0, 4) = "MB"
   With 元データ
     For i = 1 To 行見出し.Rows.Count
       For j = 1 To 列見出し.Count
         data = .Item(i, j).Value
         If Not IsEmpty(data) Then
           If data Like "*[あいうえお]*" Then  '★追加
             k = k + 1
             結果(k, 1) = 行見出し(i, 1).Value
             結果(k, 2) = 行見出し(i, 2).Value
             結果(k, 3) = 列見出し(1, j).Value
             結果(k, 4) = data
           End If                '★追加
         End If
       Next
     Next
   End With
 End With
 
 With Worksheets("結果")
   .UsedRange.ClearContents
   .Range("A1").Resize(k + 1, 4).Value = 結果
 End With
  
 
End Sub

> If data Like "*[あいうえお]*" Then  '★追加


If data Like "[あいうえお]" Then  '★追加

のほうがよかったかもしれません。

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