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 -
引用なし
パスワード
   こんばんは
　以下のデータ整理をするのに、ExcelＶＢＡの力で、ぜひ問題解決方法をご指導下さい。

元データ（シートＡ）
　　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　　　 　　　　　　　　　　　+　　　　　　　　　　 *
・
・

結果（シートＢ）
　　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("シートＡ").Cells(1, "A")

　　'◆結果の先頭セル位置を基準とする（A列の列見出しのセル位置）
　　Set rngResult = Worksheets("シートＢ").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)
　　　　　　　　'"シートＢ"に転記
　　　　　　　　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("シートＡ").Cells(1, "A")

　　'◆結果の先頭セル位置を基準とする（A列の列見出しのセル位置）
　　Set rngResult = Worksheets("シートＢ").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)
　　　　　　　　'"シートＢ"に転記
　　　　　　　　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」の結果を消去する様にしました
　　　　　　　　　　　　　　↑シートＢの結果を消去するようにしたとは
　　　　　　　　　　　　　　　どんな意味でしょうか？
>
【58218】Re:データの並べ替えについて
回答  Hirofumi  - 08/10/12(日) 4:58 -
引用なし
パスワード
   ▼夜勤担当 さん：
>こんばんは！
>返事遅くなり、すいません。
>列見出しが表示されるようになりました。
>
>>列見出しを付けるついでに、「シートB」の結果を消去する様にしました
>　　　　　　　　　　　　　　↑シートＢの結果を消去するようにしたとは
>　　　　　　　　　　　　　　　どんな意味でしょうか？
>>

前のコードでは、「シートB」に対して何もしないで書き込みを行う状態でした
今回は、結果を書き込む前に「シートB」の使用範囲をClearContentsしている
と言う事です
【58228】Re:データの並べ替えについて
お礼  夜勤担当  - 08/10/12(日) 21:21 -
引用なし
パスワード
   わかりました。
シートＢに複数回書き込んでしても、前のデータは残らなくなります。
【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