ここから本文です

VBAのコードを教えてください。 昨日質問をしたものですが、私の理解が足らず回...

アバター

ID非公開さん

2020/5/2210:38:47

VBAのコードを教えてください。

昨日質問をしたものですが、私の理解が足らず回答してくださった方に
不快な思いをさせてしまったため、質問内容を整理して再度質問させていただきます。

前回ご回答くださった方、本当に申し訳ありませんでした。

1行目は見出し、2行目には項目タイトルが入っています。
取引先コードがA列、取引先名がB列、取引品名詳細がその後S列まで入っているのですが、
取引先コード別に新規ブックを作成するマクロを作りたいです。

また、新規ブックを作成した際に、2行目までのタイトルや、データ元の書式・入力規則・行列幅等すべてを反映させ、新規で作成されたブックのファイル名とシート名を"A列_B列"にしたいです。

GW中にマクロの入門編から少しずつ勉強を始めたため、
自身がやりたいことは全然到達レベルではないのは承知しております。
今後ちゃんと勉強しますので、ご教示いただけると幸いです。
よろしくお願いいたします。

ネット上で検索したコードを載せておきます。

ーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーー
Option Explicit



Sub 転記()

Dim データ範囲 As Range

Dim 条件範囲 As Range

Dim 列 As Long

Dim シート As Worksheet

Dim i As Long

Set データ範囲 = Range("A1").CurrentRegion

列 = 2

Set 条件範囲 = データ範囲.Cells(1).Offset(0, データ範囲.Columns.Count + 1)

データ範囲.Columns(列).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=条件範囲, Unique:=True

Set 条件範囲 = 条件範囲.CurrentRegion

For i = 2 To 条件範囲.Rows.Count

条件範囲.Cells(2, 1).Value = 条件範囲.Cells(i, 1).Value

Set シート = Worksheets.Add(after:=Worksheets(Worksheets.Count))

シート.Name = 条件範囲.Cells(2, 1).Value

データ範囲.AdvancedFilter Action:=xlFilterCopy, _

CriteriaRange:=条件範囲.Rows("1:2"), CopyToRange:=シート.Range("A1")

シート.Range("A1").CurrentRegion.EntireColumn.AutoFit

Next i

条件範囲.Clear

End Sub

補足新規で作成されたブックのファイル名とシート名を"A列_B列"にしたいです。
⇒すみません、"取引先コード_取引先名" の誤りです。

閲覧数:
102
回答数:
1
お礼:
500枚

違反報告

ベストアンサーに選ばれた回答

アバター

ID非公開さん

編集あり2020/5/2608:13:50

行幅、列幅、その他書式などを全てコピーするにはコピー1回では出来ないので、ブックをコピーして不必要な行を削除。これを取引先コード分繰り返す。の方がスムーズかもしれませんね。

ちなみに元データのブックはシートは一つだけですか?



−−−−−−−−−−−−−−−−−−−−−−−−−−−−

以下、作成したコードです。


Option Explicit
Sub test()

Dim Wb1 As Workbook
Dim Ws1 As Worksheet
Dim WsBuf As Worksheet
Set Wb1 = ThisWorkbook '元データブック
Set Ws1 = Wb1.Sheets("Sheet1") '元データシート
Ws1.Copy after:=Ws1
Set WsBuf = ActiveSheet 'プログラム起動中に使うWs1のコピーシート(以降元データシートとして使用)


Const headRow As Long = 2 '見出し行数
Dim lastRow As Long
lastRow = WsBuf.Cells(Rows.Count, 1).End(xlUp).Row '最終行


WsBuf.UsedRange.Offset(headRow).Resize(lastRow - headRow).Sort _
key1:=WsBuf.Cells(headRow, 1), order1:=xlAscending, Header:=xlNo '元データを列1をキーにして昇順にソート

WsBuf.Rows.Hidden = True '元データシートの行を全て再表示
WsBuf.Rows(1).Resize(headRow).EntireRow.Hidden = True '元データシートの見出し行を非表示



'元データの列1をキーにして、上から順番に該当行を見出し行と共に新規ブックへコピー(新規ブック名・新規シート名は"列1_列2")
'保存場所:newSavePath
'方法:
'・元データシートをコピー
'・該当行を非表示にする
'・可視セルのみ削除
'・非表示行を再表示
'・シート名を変更
'・新規ブック名で保存
'・これをコピーするデータがなくなるまでループ

Dim newSavePath As String
newSavePath = ThisWorkbook.Path & "¥"'コピー先保存場所

Dim Wb2 As Workbook 'コピー先ブック
Dim Ws2 As Worksheet 'コピー先シート
Dim newSheetName As String '新規シート名
Dim newBookName As String '新規ブック名
Dim matchCnt As Long '該当行数
Dim rowCnt As Long '抽出用行番号カウンタ-

rowCnt = headRow + 1

Do While WsBuf.Cells(rowCnt, 1) <>""

WsBuf.Copy
Set Wb2 = ActiveWorkbook
Set Ws2 = Wb2.ActiveSheet
newSheetName = Ws2.Cells(rowCnt, 1) & "_" & Ws2.Cells(rowCnt, 2)
newBookName = newSheetName & ".xlsx"
With Ws2
matchCnt = WorksheetFunction.CountIf(.Columns(1), .Cells(rowCnt, 1))
.Rows(rowCnt).Resize(matchCnt).Hidden = True
.Rows.SpecialCells(xlCellTypeVisible).Delete
.Rows.Hidden = False
.Name = newSheetName
End With

Wb2.SaveAs Filename:=newSavePath &newBookName, FileFormat:=xlOpenXMLWorkbook
Wb2.Close savechanges:=False

rowCnt = rowCnt + matchCnt

Loop

Application.DisplayAlerts = False
WsBuf.Delete
Application.DisplayAlerts = True
Wb1.Activate
Ws1.Activate

End Sub

  • アバター

    質問者

    ID非公開さん

    2020/5/2213:50:27

    haru さま

    ご回答ありがとうございます。
    元データのブックはシート2枚(別で集計用シートがあります)です。
    こちらを別ブックで集計のほうが良いというのであれば、別ブックでの集計でも問題ないです。

  • その他の返信を表示

返信を取り消しますが
よろしいですか?

  • 取り消す
  • キャンセル

アバター

質問した人からのコメント

2020/5/26 09:10:16

何日間にもわたり、明らかに知識のない私を丁寧に導いてくださり本当にありがとうございました!!
御礼を言うしか出来ず、本当に申し訳ありません。
教えていただいたコードを、自身できちんと理解し、今後メンテナンスが出来るよう日々勉強を続けていきます。

この度は本当にありがとうございました!

この質問につけられたタグ

みんなで作る知恵袋 悩みや疑問、なんでも気軽にきいちゃおう!

Q&Aをキーワードで検索:

Yahoo! JAPANは、回答に記載された内容の信ぴょう性、正確性を保証しておりません。
お客様自身の責任と判断で、ご利用ください。
本文はここまでです このページの先頭へ

「追加する」ボタンを押してください。

閉じる

※知恵コレクションに追加された質問は選択されたID/ニックネームのMy知恵袋で確認できます。

不適切な投稿でないことを報告しました。

閉じる