ここから質問投稿すると、最大10000ポイント当たる!!!! >>

こんにちは。エクセルのマクロに関する質問です。
添付写真のシートのデータをD列の保管場所ごとにそれぞれ別のシートに分割するマクロを作成しようとしています。

ポイントは、
1.保管場所の数だけ新しくシートを追加。
(分割すべきシートは、左から2番目。新たに追加されるシートは3番目にくるようにしたい。)
2.D列の保管場所名を新しいシートのタイトルにする。
3.9行までのデータは、すべてのシートにおいて同様。(デフォルト)
4.10行以降のデータは、各保管場所のデータが入るようにしたい。

データは、縦約1300行、横AE列まであります。 AE列の9行にはデータが入力されていますが、
AE列の10行以降のデータは空白です。保管場所の数は、処理するデータの中身によって変わるため、変数にしたいです。どうぞ宜しくお願いします。

※ちなみにネットで見つけた以下のマクロで実行した時は、上記1〜3までの問題なかったのですが、上記4のところが失敗しました。(各シートの内容が分割されず、元シートのデータがそのままコピーされていました。)

Dim lr As Long
Dim ws As Worksheet
Dim vcol, i As Integer
Dim icol As Long
Dim myarr As Variant
Dim title As String
Dim titlerow As Integer
vcol = 4
Set ws = Sheets("照合表")
lr = ws.Cells(ws.Rows.Count, vcol).End(xlUp).Row
title = "A1:AE1"
titlerow = ws.Range(title).Cells(1).Row
icol = ws.Columns.Count
ws.Cells(1, icol) = "Unique"
For i = 2 To lr
On Error Resume Next
If ws.Cells(i, vcol) <> "" And Application.WorksheetFunction.Match(ws.Cells(i, vcol), ws.Columns(icol), 0) = 0 Then
ws.Cells(ws.Rows.Count, icol).End(xlUp).Offset(1) = ws.Cells(i, vcol)
End If
Next
myarr = Application.WorksheetFunction.Transpose(ws.Columns(icol).SpecialCells(xlCellTypeConstants))
ws.Columns(icol).Clear
For i = 2 To UBound(myarr)
ws.Range(title).AutoFilter field:=vcol, Criteria1:=myarr(i) & ""
If Not Evaluate("=ISREF('" & myarr(i) & "'!A1)") Then
Sheets.Add(after:=Worksheets(Worksheets.Count)).Name = myarr(i) & ""
Else
Sheets(myarr(i) & "").Move after:=Worksheets(Worksheets.Count)
End If
ws.Range("A" & titlerow & ":A" & lr).EntireRow.Copy Sheets(myarr(i) & "").Range("A1")
Sheets(myarr(i) & "").Columns.AutoFit
Next
ws.AutoFilterMode = False
ws.Activate
End Sub

「エクセルのマクロを使って一つのシートにあ」の質問画像

A 回答 (2件)

ニーズを把握しているわけではないのですが、自分なら、エクセルのフィルタ機能で済ませます。


おそらく、これで目的を達成できると思います。
(マクロを使うのは手段の一つであり、他の手段であってもよいはずです)

◆やり方
1. 黄色になっている行全体を選択
2. データ → フィルタ
3. 保管場所のところの▼マークをクリック → 表示したい項目にチェックをつける → OK
    • good
    • 0

こんにちは。



以下のあたりがヒントになるのではないでしょうか。
http://officetanaka.net/excel/vba/db/db03.htm
    • good
    • 0

お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!

このQ&Aと関連する良く見られている質問

Qエクセルで各シート毎にブックに分割したい

エクセルの1つのブックに複数の名前がついたシートがあり、その各シート毎にシート名のブックに分割したいのです。
シートが少なければ手作業で分割するのですが、100枚近くのシートがあるので、できればマクロで一括処理できれば助かるのですが。
過去ログで複数のブックのシートを一つのブックにまとめる事例がありましたので、その逆もできると思うのですが。
よろしくお願いします。

Aベストアンサー

こんばんは。

こんな感じで如何でしょうか?

Sub splitBook()

Const path As String = "C:\" '\まで記述

Dim bk As Workbook
Set bk = ActiveWorkbook

Dim st As Worksheet
For Each st In bk.Sheets

Workbooks.Add
st.Copy Before:=ActiveWorkbook.Sheets(1)
ActiveWorkbook.SaveAs path & st.Name & ".xls"
ActiveWorkbook.Close

Next

End Sub

Qエクセルの1シートの内容を複数のシートに分割したい。

前任者から引き継いだエクセルのファイルを見やすくしたいと思っています。

1ページにつき1つの表が作られているのですが、一枚のシートのページ数が膨大で、とても見にくいのです。ページ毎に(一つの表毎に)違うシートにしたいのですが、地道にコピー&ペーストをしなければならないでしょうか。

一発でバチッとページ毎にシートにできる方法はありますか?

windowsXP, Excel 2002を使用しています。

Aベストアンサー

失礼しました。間違いがありました。

再度以下のモジュールで試してください。
ちなみに、 入力データがカラム120まであって、これを30カラムずつ分解するとしたら、
wCOLUMN = 30 '1ページのカラム列数
wSHEET = 4 '1ページのカラム分解数
になります。すみません。

Sub PAGE_分割()
Dim sLine As Integer
Dim eLine As Integer
Dim wPAGE As Integer
Dim wLINE As Integer
Dim wCOLUMN As Integer
Dim wSHEET As Integer
Dim sCOL As Integer
Dim eCOL As Integer
Dim DataSht As String
Dim wSHEETCnt As Integer
'
wSHEETCnt = 0
wPAGE = 10 'ページ数
wLINE = 50 '1ページの行数
wCOLUMN = 30 '1ページのカラム列数
wSHEET = 4 '1ページのカラム分解数
DataSht = "DATA" 'データのシート名
'ROW
For wRow = 1 To wPAGE
If wRow = 1 Then
sLine = 1
sCOL = 1
Else
sLine = eLine + 1
sCOL = eCOL + 1
End If
eLine = wRow * wLINE
'COLUMN
For wCOL = 1 To wSHEET
If wCOL = 1 Then
sCOL = 1
Else
sCOL = eCOL + 1
End If
eCOL = wCOL * wCOLUMN

Sheets.Add after:=Sheets(Sheets.Count) 'シートを生成
wSHEETCnt = wSHEETCnt + 1
ActiveSheet.Name = "PAGE" & wSHEETCnt 'シート名を付ける
'ページ単位でデータをコピー
Sheets(DataSht).Range(Sheets(DataSht).Cells(sLine, sCOL), Sheets(DataSht).Cells(eLine, eCOL)).Copy _
Destination:=Sheets("PAGE" & wSHEETCnt).Range("A1")
Next
Next
End Sub

失礼しました。間違いがありました。

再度以下のモジュールで試してください。
ちなみに、 入力データがカラム120まであって、これを30カラムずつ分解するとしたら、
wCOLUMN = 30 '1ページのカラム列数
wSHEET = 4 '1ページのカラム分解数
になります。すみません。

Sub PAGE_分割()
Dim sLine As Integer
Dim eLine As Integer
Dim wPAGE As Integer
Dim wLINE As Integer
Dim wCOLUMN As Integer
Dim wSHEET As Integer
Dim sCOL As Integer
Dim eCOL As Integer
Dim DataSht As String
...続きを読む

Qエクセルの1シートを項目別に別シートへ分ける方法

エクセル2010で1シートのデータを項目別に別シートへ自動的に分割する方法で困っています。
検索するとマクロを使うと書いていますが、マクロはほとんど使ったことが無いのもあって、わかりませんでした。

シート1
A列(日付8ケタ+商品番号6ケタ) B列(売上額)
20130515000004           300
20130515000006           100
20130518000004           300
20130519000001           500
20130519000004           300
・・・                   ・・・
をA列の日付部分上8ケタを使って日別にシートを分け、
シート名をuriage20130515(uriageと日付8ケタ)という名前にしシート名+CSV形式で保存したいです。

シート2 シート名:uriage20130515
A列         B列
20130515000004 300
20130515000006 100

シート3 シート名:uriage20130518
A列         B列
20130518000004 300

シート4 シート名:uriage20130519
A列         B列
20130519000001 500
20130519000004 300

このように自動で別シートに分割した上で、シート名CSV形式で保存まで自動でできるとありがたいです。

自動化できるならシートを分割するマクロ、シート名でCSV保存するマクロが一つのマクロになっていても、分かれていてもOKです。

このようなことはできますか?

よろしくお願いします。

エクセル2010で1シートのデータを項目別に別シートへ自動的に分割する方法で困っています。
検索するとマクロを使うと書いていますが、マクロはほとんど使ったことが無いのもあって、わかりませんでした。

シート1
A列(日付8ケタ+商品番号6ケタ) B列(売上額)
20130515000004           300
20130515000006           100
20130518000004           300
20130519000001           500
20130519000004           300
・・・           ...続きを読む

Aベストアンサー

手順:
元データのブックを一度保存して開き直す
ALT+F11を押す
現れた画面で挿入メニューから標準モジュールを挿入する
現れたシートに下記をコピー貼り付ける

sub macro1()
 dim myPath as string
 dim myFile as string
 dim h as range
 dim s as string
 dim w as worksheet

 mypath = thisworkbook.path & "\"
 on error resume next
 kill mypath & "*.csv"
 application.displayalerts = false
 for each w in worksheets
  if w.name <> activesheet.name then w.delete
 next
 application.displayalerts = true
 on error goto errhandle

 for each h in range("A1:A" & range("A65536").end(xlup).row)
 if isnumeric(h.value) then
  s = left(h.value, 8)

 ’CSVに書き出し
  open mypath & "uriage" & s & ".csv" for append as #1
  print #1, h.value & "," & h.offset(0,1).value
  close #1

 ’シートに書き出し
  h.entirerow.copy worksheets(s).range("A65536").end(xlup).offset(1)

 end if
 next

 for each w in worksheets
  w.columns("A:B").autofit
 next
 exit sub

errhandle:
 worksheets.add after:=worksheets(worksheets.count)
 activesheet.name = s
 range("A1:B1") = array("date", "value")
 resume
end sub


ファイルメニューから終了してエクセルに戻る
ALT+F8を押しマクロを実行すると,CSVを書き出す。



#「CSVを書き出す」のが目的で「別シートに振り分ける」こと自体に目的はないと思いましたが,まぁご相談なのでシートに書き出しも追加しました。。。と思って書き足してったら無駄に長いマクロになっちゃいました。あんまりイミなかったです。

手順:
元データのブックを一度保存して開き直す
ALT+F11を押す
現れた画面で挿入メニューから標準モジュールを挿入する
現れたシートに下記をコピー貼り付ける

sub macro1()
 dim myPath as string
 dim myFile as string
 dim h as range
 dim s as string
 dim w as worksheet

 mypath = thisworkbook.path & "\"
 on error resume next
 kill mypath & "*.csv"
 application.displayalerts = false
 for each w in worksheets
  if w.name <> activesheet.name then w.delete
 next
 a...続きを読む


人気Q&Aランキング