Excel VBA質問箱 IV

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

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


27 / 12952 ツリー ←次へ | 前へ→

【78743】特定の文字列と特定の文字列の間にある行をコピー貼付 藁にもすがりたい者 17/1/12(木) 11:50 質問[未読]

【78745】Re:特定の文字列と特定の文字列の間にある... β 17/1/13(金) 8:56 発言[未読]
【78747】Re:特定の文字列と特定の文字列の間にある... 藁にもすがりたい者 17/1/13(金) 9:19 回答[未読]
【78750】Re:特定の文字列と特定の文字列の間にある... β 17/1/13(金) 14:16 発言[未読]
【78751】Re:特定の文字列と特定の文字列の間にある... β 17/1/13(金) 14:35 発言[未読]
【78754】Re:特定の文字列と特定の文字列の間にある... 藁にもすがりたい者 17/1/13(金) 15:25 お礼[未読]

【78745】Re:特定の文字列と特定の文字列の間にあ...
発言  β  - 17/1/13(金) 8:56 -

引用なし
パスワード
   ▼藁にもすがりたい者 さん:

なかなかレスがつきませんねぇ。

元シートのレイアウトの提示はあるのですが、その結果の 店名A と 店名B の
できあがりイメージも具体的なレイアウトとして提示されてはいかがでしょう。

そうすると、回答がつきやすいと思います。

【78747】Re:特定の文字列と特定の文字列の間にあ...
回答  藁にもすがりたい者  - 17/1/13(金) 9:19 -

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

なるほど…できあがりのイメージをお伝えしてませんでしたもんね…
すみません、なにぶん初めてこういうサイトにお世話になるため不慣れで…

出来上がりのイメージとしては
マクロを実行すると店名A〜店名Lまでのシートが作成され
それぞれのシートにデータが下記のように貼付けされていて欲しいです。


シート名:店名A
    A    B   C   D   E   F   G   H   I
1   数値  店名A  数値  数値  数値  数値  数値  数値  数値
2   数値  数値  数値  科目  金額 消費税
3   数値  数値  数値  科目  金額 消費税
4   数値  数値  数値  科目  金額 消費税
5   数値  数値  数値  科目  金額 消費税
6   数値  数値  数値  科目  金額 消費税
7   数値  数値  数値  科目  金額 消費税
8   数値  数値  数値  科目  金額 消費税
9   数値  数値  数値  科目  金額 消費税
10   数値  数値  数値  科目  金額 消費税
.
.
.
.
50   数値  店名A  数値  数値  数値  数値  数値  数値  数値
51   数値  数値  数値  科目  金額 消費税
52   数値  数値  数値  科目  金額 消費税


ここまでできればあとは関数で必要な情報を抜き出せるので
なんとかここまでをマクロで作業できると非常にありがたいです。

不慣れでマクロもわかっていないような者ですが
こちらの方々のお力が借りられたら幸いでございます。

宜しくお願いいたします。


>▼藁にもすがりたい者 さん:
>
>なかなかレスがつきませんねぇ。
>
>元シートのレイアウトの提示はあるのですが、その結果の 店名A と 店名B の
>できあがりイメージも具体的なレイアウトとして提示されてはいかがでしょう。
>
>そうすると、回答がつきやすいと思います。

【78750】Re:特定の文字列と特定の文字列の間にあ...
発言  β  - 17/1/13(金) 14:16 -

引用なし
パスワード
   ▼藁にもすがりたい者 さん:

B列が店名なのか数値なのかの判断が必要ですが、店名は【文字列】、それ以外は数値という決めつけです。

Sub Test()
  Dim r As Range
  Dim a As Range
  Dim d As Range
  Dim i As Long
  Dim dic As Object
  Dim nm As String
  Dim pos As Range
  
  Set dic = CreateObject("Scripting.Dictionary")
  
  With Sheets("Sheet1")
    Set r = .Range("B6", .Range("B" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeConstants, xlNumbers)
    
    For Each a In r.Areas
      Set d = a.Offset(-1).Resize(a.Rows.Count + 1)
      nm = d(1).Value '店名
      If Not dic.exists(nm) Then '初めて出現?
        dic(nm) = True
        If Not IsObject(Evaluate(nm & "!A1")) Then 'シート無し?
          Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = nm
        End If
        With Sheets(nm)
          .Cells.ClearContents
          Set pos = .Range("A1")
        End With
      End If
      d.EntireRow.Copy pos
      Set pos = pos.Offset(d.Rows.Count)
    Next
    
  End With
End Sub

【78751】Re:特定の文字列と特定の文字列の間にあ...
発言  β  - 17/1/13(金) 14:35 -

引用なし
パスワード
   ▼藁にもすがりたい者 さん:

元シート(コードでは "Sheet1") の店名ですが、
必ずしも、まとまって(固まって)出現しないというケースも想定しますと
以下にしておいたほうが安全ですね。

Sub Test2()
  Dim r As Range
  Dim a As Range
  Dim d As Range
  Dim i As Long
  Dim dic As Object
  Dim nm As String
  Dim pos As Range
  
  Set dic = CreateObject("Scripting.Dictionary")
  
  With Sheets("Sheet1")
    Set r = .Range("B6", .Range("B" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeConstants, xlNumbers)
    
    For Each a In r.Areas
      Set d = a.Offset(-1).Resize(a.Rows.Count + 1)
      nm = d(1).Value '店名
      If Not dic.exists(nm) Then '初めて出現?
        dic(nm) = True
        If Not IsObject(Evaluate(nm & "!A1")) Then 'シート無し?
          Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = nm
        End If
        With Sheets(nm)
          .Cells.ClearContents
          Set pos = .Range("A1")
        End With
      Else
        Set pos = Sheets(nm).Range("A" & Rows.Count).End(xlUp).Offset(1)
      End If
      d.EntireRow.Copy pos
    Next
    
  End With
End Sub

【78754】Re:特定の文字列と特定の文字列の間にあ...
お礼  藁にもすがりたい者  - 17/1/13(金) 15:25 -

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

すごい…違うケースも想定してのコード作成を…
感動で胸が一杯です…

こちらでも私の思い描いた形になりました!

私のようなマクロを理解していない者にも
暖かく対応していただき、ありがとうございました!


>▼藁にもすがりたい者 さん:
>
>元シート(コードでは "Sheet1") の店名ですが、
>必ずしも、まとまって(固まって)出現しないというケースも想定しますと
>以下にしておいたほうが安全ですね。
>
>Sub Test2()
>  Dim r As Range
>  Dim a As Range
>  Dim d As Range
>  Dim i As Long
>  Dim dic As Object
>  Dim nm As String
>  Dim pos As Range
>  
>  Set dic = CreateObject("Scripting.Dictionary")
>  
>  With Sheets("Sheet1")
>    Set r = .Range("B6", .Range("B" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeConstants, xlNumbers)
>    
>    For Each a In r.Areas
>      Set d = a.Offset(-1).Resize(a.Rows.Count + 1)
>      nm = d(1).Value '店名
>      If Not dic.exists(nm) Then '初めて出現?
>        dic(nm) = True
>        If Not IsObject(Evaluate(nm & "!A1")) Then 'シート無し?
>          Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = nm
>        End If
>        With Sheets(nm)
>          .Cells.ClearContents
>          Set pos = .Range("A1")
>        End With
>      Else
>        Set pos = Sheets(nm).Range("A" & Rows.Count).End(xlUp).Offset(1)
>      End If
>      d.EntireRow.Copy pos
>    Next
>    
>  End With
>End Sub

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