Excel VBA質問箱 IV

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

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


31 / 13180 ツリー ←次へ | 前へ→

【80045】1つのリストから同じブック内に複数明細を生成したい さくらこ 18/7/14(土) 14:58 質問[未読]

【80054】Re:1つのリストから同じブック内に複数明細... さくらこ 18/7/16(月) 2:20 お礼[未読]
【80055】Re:1つのリストから同じブック内に複数明細... γ 18/7/16(月) 7:21 発言[未読]
【80056】Re:1つのリストから同じブック内に複数明細... γ 18/7/16(月) 7:33 発言[未読]
【80059】Re:1つのリストから同じブック内に複数明細... さくらこ 18/7/16(月) 13:19 お礼[未読]

【80054】Re:1つのリストから同じブック内に複数明...
お礼  さくらこ  - 18/7/16(月) 2:20 -

引用なし
パスワード
   アドバイス頂いた方法とは少し違うかもしれませんが、色々なサイト情報を参考に、一旦はなんとか目的の動作をするマクロが作れました。
これまで、VBAは既存のコードの部分修正程度しかしたことがありませんでしたが、こちらのサイトをはじめ、様々な情報がとても参考になりました。
お作法もなっていないめちゃくちゃな記述かもしれませんが、ひとまずこれで使ってみようと思います。
また何か困ったことがあれば、相談させてください。
この度は、ありがとうございました。

----------
Sub 明細シート作成()

wsList.Select
Range("A4:A200").Select
Selection.Copy
wsClient.Select
Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValues
wsList.Select
Range("C4:C200").Select
Selection.Copy
wsClient.Select
Range("B1").Select
Selection.PasteSpecial Paste:=xlPasteValues
wsList.Select
Range("S4:S200").Select
Selection.Copy
wsClient.Select
Range("C1").Select
Selection.PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
ActiveSheet.Range("$A$1:$C$197").RemoveDuplicates Columns:=Array(1, 2, 3), Header:=xlNo
wsList.Select
Range("A1").Select

Dim rowsList As Long, rowsClient As Long
rowsList = wsList.Cells(Rows.Count, 1).End(xlUp).Row
rowsClient = wsClient.Cells(Rows.Count, 1).End(xlUp).Row

Dim n As Long
For n = 1 To rowsClient

  Dim txt As String, no As String, name As String, i As Long, k As Long
  txt = wsClient.Cells(n, 1).Value
  no = wsClient.Cells(n, 2).Value
  name = wsClient.Cells(n, 3).Value
  k = 25
  wsForm.Copy After:=wsForm
  ActiveSheet.name = txt
  ActiveSheet.Range("B34").Value = txt
  ActiveSheet.Range("B5").Value = no
  ActiveSheet.Range("A3").Value = name
   For i = 4 To rowsList
   If wsList.Cells(i, 1).Value = txt Then
   wsList.Cells(i, 6).Copy ActiveSheet.Cells(k, 1)
   wsList.Cells(i, 8).Copy ActiveSheet.Cells(k, 8)
   k = k + 1
   End If
   Next i

Next n

End Sub
----------

【80055】Re:1つのリストから同じブック内に複数明...
発言  γ  - 18/7/16(月) 7:21 -

引用なし
パスワード
   頑張られましたね。すごいです。
スキルアップになったことと推察いたします。

老婆心ながら、すこし体裁を整えてみました。
参考にしてください。

なお、冒頭にOption Explicitを入れることをお薦めします。
こうすると、未宣言の変数には警告が出されます。
このことによって思わぬミスタイプを防止することができます。
これを付けないばかりにデバッグに相当な時間がかかってしまうことがあります。
(なお、
ツール − オプション − 編集 で
「変数の宣言を強制する」にチェックを入れておけば、
モジュールを作成した時点で、Option Explicitが自動的に挿入されるので、
手間が省けます。
一度だけチェックを入れておけば、以後、気にする必要はありません。)

Option Explicit
Sub 明細シート作成2()
  Dim wsList As Worksheet
  Dim wsClient As Worksheet
  Dim wsForm As Worksheet
  Dim ws As Worksheet
  Dim rowsList As Long, rowsClient As Long
  Dim n As Long
  Dim txt As String, no As String, name As String
  Dim i As Long, k As Long
  
  Set wsList = Worksheets("List")
  Set wsClient = Worksheets("Client")
  Set wsForm = Worksheets("Form")

  wsList.Range("A4:A200").Copy
  wsClient.Range("A1").PasteSpecial Paste:=xlPasteValues

  wsList.Range("C4:C200").Copy
  wsClient.Range("B1").PasteSpecial Paste:=xlPasteValues

  wsList.Range("S4:S200").Copy
  wsClient.Range("C1").PasteSpecial Paste:=xlPasteValues

  Application.CutCopyMode = False

  wsClient.Range("$A$1:$C$197").RemoveDuplicates Columns:=Array(1, 2, 3), Header:=xlNo

  wsList.Select
  Range("A1").Select

  rowsList = wsList.Cells(Rows.Count, 1).End(xlUp).Row
  rowsClient = wsClient.Cells(Rows.Count, 1).End(xlUp).Row

  For n = 1 To rowsClient
    txt = wsClient.Cells(n, 1).Value
    no = wsClient.Cells(n, 2).Value
    name = wsClient.Cells(n, 3).Value
    
    k = 25
    wsForm.Copy After:=wsForm
    Set ws = ActiveSheet
    ws.name = txt
    ws.Range("B34").Value = txt
    ws.Range("B5").Value = no
    ws.Range("A3").Value = name
    For i = 4 To rowsList
      If wsList.Cells(i, 1).Value = txt Then
        wsList.Cells(i, 6).Copy ActiveSheet.Cells(k, 1)
        wsList.Cells(i, 8).Copy ActiveSheet.Cells(k, 8)
        k = k + 1
      End If
    Next i
  Next n
End Sub

【80056】Re:1つのリストから同じブック内に複数明...
発言  γ  - 18/7/16(月) 7:33 -

引用なし
パスワード
   フィルタオプションとオートフィルタを使った、私案を参考までに示します。

なお、フィルタオプションを使う関係で、見出しが必須です。
・ListシートのA3,C3,F3,F3,S3には項目見出しを入れます。
・ClientシートのA1,B1,C1にも見出しを、
 それぞれListシートのA3,C3,S3と全く同一のものを記入してください。

Sub 明細シート作成3()
  Dim wsList   As Worksheet
  Dim wsClient  As Worksheet
  Dim wsForm   As Worksheet
  Dim ws     As Worksheet
  
  Dim lastRow   As Long
  Dim myRange   As Range
  Dim myBody   As Range
  Dim r      As Range

  Dim rowsClient As Long
  Dim n      As Long
  Dim txt     As String
  Dim no     As String
  Dim name    As String
  Dim k      As Long

  Set wsList = Worksheets("List")
  Set wsClient = Worksheets("Client")
  Set wsForm = Worksheets("Form")

  'フィルタ範囲の指定
  lastRow = wsList.Cells(wsList.Rows.Count, 1).End(xlUp).Row
  Set myRange = wsList.Range(wsList.Cells(3, "A"), wsList.Cells(lastRow, "S"))
  
  'その本体部分(つまり見出しを除いた部分)
  Set myBody = Intersect(myRange, myRange.Offset(1))

  '重複を除いて抽出
  myRange.AdvancedFilter Action:=xlFilterCopy, _
              CopyToRange:=wsClient.Range("A1:C1"), Unique:=True

  '転記
  rowsClient = wsClient.Cells(wsClient.Rows.Count, 1).End(xlUp).Row
  For n = 2 To rowsClient
    txt = wsClient.Cells(n, 1).Value  '受注No
    no = wsClient.Cells(n, 2).Value   '管理No
    name = wsClient.Cells(n, 3).Value  '注文者氏名

    '管理No 毎のシートを作成
    wsForm.Copy After:=Worksheets(Worksheets.Count)
    Set ws = ActiveSheet
    ws.name = txt

    '固定項目の転記
    ws.Range("B34").Value = txt
    ws.Range("B5").Value = no
    ws.Range("A3").Value = name

    '管理Noを指定して抽出(品目毎データの転記用)
    myRange.AutoFilter Field:=3, Criteria1:=no

    'その転記
    k = 25
    For Each r In myBody.Columns(1).SpecialCells(xlCellTypeVisible)
      ws.Cells(k, 1) = r.Cells(1, 6).Value
      ws.Cells(k, 8) = r.Cells(1, 8).Value
      k = k + 1
    Next
  Next
  myRange.AutoFilter
End Sub

 

【80059】Re:1つのリストから同じブック内に複数明...
お礼  さくらこ  - 18/7/16(月) 13:19 -

引用なし
パスワード
   詳細にご教示いただき、ありがとうございます。
Option Explicitやオートフィルタの使い方など、とても勉強になります!
今回試行錯誤してみて、一歩踏み出せたと思うので、これからも続けて勉強しようと思います。
教えていただいたコードも、しっかり確認して、使えるようにします!
またつまずいた時はアドバイス求めてこちらに質問させてください。
よろしくお願いいたします。
本当にありがとうございました!!

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