Excel VBA質問箱 IV

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

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


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

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

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

【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

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