Excel VBA質問箱 IV

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

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


17802 / 76738 ←次へ | 前へ→

【64384】Re:受注データの表示形式について
回答  UO3  - 10/2/1(月) 12:57 -

引用なし
パスワード
   ▼Akari さん:

処理速度はhirofumiさんのものと比べ、自信はありませんが
こんなやりかたもあるかもしれません。

Option Explicit

Sub Sample()
Dim myDic As Object
Dim sepChr As String
Dim myKey
Dim myLines As Long
Dim aaa
Dim i As Long

  Set myDic = CreateObject("Scripting.Dictionary")
  Worksheets("Sheet2").Range("A1:D1").Value = Worksheets("Sheet1").Range("A1:D1").Value
  Worksheets("Sheet2").Range("E1") = "受注先グループ"
  
  With Worksheets("Sheet1")
  
    myLines = .UsedRange.Rows.Count
  
    For i = 2 To myLines
      myKey = .Range("A" & i) & Chr(13) & _
        .Range("B" & i) & Chr(13) & _
        .Range("C" & i) & Chr(13) & _
        .Range("D" & i)
      sepChr = ""
      If myDic(myKey) <> "" Then sepChr = "、"
      myDic(myKey) = myDic(myKey) & sepChr & .Range("E" & i)
    Next
    
  End With
  
  i = 2
  
  With Worksheets("Sheet2")
    
    For Each myKey In myDic
      aaa = Split(myKey, Chr(13))
      .Range("A" & i).Resize(, 4) = aaa
      .Range("E" & i) = myDic(myKey)
      i = i + 1
    Next
  
  End With
  
  Set myDic = Nothing
  
End Sub

0 hits

【64135】受注データの表示形式について Akari 10/1/21(木) 14:39 質問
【64141】Re:受注データの表示形式について Hirofumi 10/1/21(木) 20:10 回答
【64375】Re:受注データの表示形式について Akari 10/1/31(日) 22:27 質問
【64384】Re:受注データの表示形式について UO3 10/2/1(月) 12:57 回答
【64482】Re:受注データの表示形式について Akari 10/2/14(日) 21:57 質問
【64539】Re:受注データの表示形式について Akari 10/2/21(日) 21:37 質問
【64540】Re:受注データの表示形式について UO3 10/2/21(日) 22:06 発言
【64543】Re:受注データの表示形式について UO3 10/2/22(月) 11:38 回答
【64640】Re:受注データの表示形式について Akari 10/2/27(土) 21:23 質問
【64644】Re:受注データの表示形式について UO3 10/2/28(日) 1:37 発言
【64645】Re:受注データの表示形式について UO3 10/2/28(日) 9:03 回答
【64680】Re:受注データの表示形式について Akari 10/3/7(日) 14:00 質問
【64544】Re:受注データの表示形式について Hirofumi 10/2/22(月) 12:30 発言
【64846】Re:受注データの表示形式について akari 10/3/18(木) 15:35 お礼
【68776】Re:受注データの表示形式について Akari 11/4/16(土) 13:57 質問

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