Ｐａｇｅ 186 ━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━ 通常モードに戻る ┃ ＩＮＤＥＸ ┃ ≪前へ │ 次へ≫ ━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━ ▼分類ごとにシートを分けたい gori 02/9/27(金) 15:52 ┗Re:分類ごとにシートを分けたい こうちゃん 02/9/30(月) 13:41 ┗Re:分類ごとにシートを分けたい gori 02/10/3(木) 16:23 ┗もう少し詳細におしえてください。 こうちゃん 02/10/3(木) 20:52 ┗Re:もう少し詳細におしえてください。 gori 02/10/7(月) 10:24 ┗Re:もう少し詳細におしえてください。 gori 02/10/7(月) 10:34 ┗Re:もう少し詳細におしえてください。 こうちゃん 02/10/7(月) 14:09 ┗うまくいきません，また教えてください． gori 02/10/8(火) 15:24 ┗Re:うまくいきません，また教えてください． こうちゃん 02/10/8(火) 21:46 ┗Re:うまくいきません，また教えてください． gori 02/10/9(水) 9:28 ┗2,3確認です こうちゃん 02/10/9(水) 10:58 ┗Re:2,3確認です gori 02/10/9(水) 16:59 ┗Bookに異常があります。少しまってね。 こうちゃん 02/10/10(木) 11:27 ┗おまちどうさま。（長文注意） こうちゃん 02/10/10(木) 13:48 ┗Re:おまちどうさま。（長文注意） gori 02/10/10(木) 15:24 ─────────────────────────────────────── ■題名 ： 分類ごとにシートを分けたい ■名前 ： gori ■日付 ： 02/9/27(金) 15:52 -------------------------------------------------------------------------
| Sheets.Add 'シート分け Sheets("Sheet1").Select Sheets("Sheet1").Name = "００１" Sheets.Add Sheets("Sheet2").Select Sheets("Sheet2").Name = "００２" Sheets.Add Sheets("Sheet3").Select Sheets("Sheet3").Name = "００３" Sheets.Add Sheets("Sheet4").Select Sheets("Sheet4").Name = "００４" Sheets.Add Sheets("Sheet5").Select Sheets("Sheet5").Name = "００５" Sheets.Add Sheets("Sheet6").Select Sheets("Sheet6").Name = "００６" Sheets.Add Sheets("Sheet7").Select Sheets("Sheet7").Name = "その他" '001 Sheets("Q_廃棄エクセルデータ").Select 行 = 1 set行 = 行 + 1 Do 行 = 行 + 3 Loop While Left(行, 3) = "001" ' MsgBox (行) Range(Rows(set行), Rows(行 - 1)).Select Selection.Copy Sheets("００１").Select ActiveSheet.Paste って書いたんですけど、全然コピーされません。 教えてください。 |
| gori さん、こんにちは レスがつかないようですね。 何をしたいのかがよくわからないのでレスが付けづらいのだと思います。 なんとなく想像だとこんなかんじでしょうか？ 「Q_廃棄エクセルデータ」シートの2行目、3行目をヘッダ（項目名行）として、3行づつセットのデータがあります。 各3行ごとのデータの1行目の1列目に"001"が含まれるデータを選択して"００１"シートにコピーします。 ってところでしょうか？ >'001 > Sheets("Q_廃棄エクセルデータ").Select > 行 = 1 > set行 = 行 + 1 > Do > 行 = 行 + 3 > > Loop While Left(行, 3) = "001" ここが何をしたいのかがわからないのです。 最初の判定時に、変数「行」には判定時点で 4 が代入されています。 当然、Left(行, 3) は Falseになってしまいます。 もし変数「行」の行のデータに"001"が含まれるということであれば・・ Loop While Left(Cells(行, 1), 3) = "001" としなければいけません。 >' MsgBox (行) > Range(Rows(set行), Rows(行 - 1)).Select > Selection.Copy > Sheets("００１").Select ペーストする位置も明示したほうがいいと思いますよ。 Range("A1").Select > ActiveSheet.Paste >って書いたんですけど、全然コピーされません。 gori さんのコードのままでも、2行目から6行目はコピーされると思いますが、全然されませんか？ |
| ▼こうちゃん さん： >gori さん、こんにちは > >レスがつかないようですね。 >何をしたいのかがよくわからないのでレスが付けづらいのだと思います。 > >なんとなく想像だとこんなかんじでしょうか？ > >「Q_廃棄エクセルデータ」シートの2行目、3行目をヘッダ（項目名行）として、3行づつセットのデータがあります。 >各3行ごとのデータの1行目の1列目に"001"が含まれるデータを選択して"００１"シートにコピーします。 > お返事ありがとうございます、全然ご返事が無くてないてました。 こうちゃんさんの想像とちょっと違いまして、 >各3行ごとのデータの1行目の1列目に"001"が含まれるデータを選択して"００１"シートにコピーします ではなくて、C列に分類コードとして“0010111101”のような10桁の数字が“0190919101”まで昇順で並んでいます。10桁のうち右から３桁の数字が”001”のものは”001”シートに行ごと移したいのです。”0020131301”なら“002”シートに移しさらに２〜３行目の項目名行もちゃんと移したいのです。 質問の内容わかっていただけたでしょうか |
| goriさん、こんばんは >お返事ありがとうございます、全然ご返事が無くてないてました。 >こうちゃんさんの想像とちょっと違いまして、 >>各3行ごとのデータの1行目の1列目に"001"が含まれるデータを選択して"００１"シートにコピーします >ではなくて、C列に分類コードとして“0010111101”のような10桁の数字が“0190919101”まで昇順で並んでいます。10桁のうち右から３桁の数字が”001”のものは”001”シートに行ごと移したいのです。”0020131301”なら“002”シートに移しさらに２〜３行目の項目名行もちゃんと移したいのです。 ここはとりあえず了解です。 「10桁のうち右から３桁」ではなく「10桁のうち左から３桁」でいいんですか？ とすれば、判定が Loop While Left(Cells(行, 3), 3) = "001" となりますね？ >質問の内容わかっていただけたでしょうか わたしの質問に答えていただいていませんが、3行ごとにセットで判定してコードの左3桁が001〜006までは各シートにコピーする、それ以外のものは「その他」シートにコピーする、でいいんですよね。 あとは、外側にもうひとつループをつけて、「Q_廃棄エクセルデータ」シートの全データを見ればいいんじゃないでしょうか？ できれば、データの並びの例をUPできませんか？ そうすればもう少しはっきり回答できると思うのですが・・ |
| ▼こうちゃん さん： こうちゃんさんおはようございます。 またまたご面倒見ていただきありがとうございます。 >「10桁のうち右から３桁」ではなく「10桁のうち左から３桁」でいいんですか？ >とすれば、判定が >Loop While Left(Cells(行, 3), 3) = "001" >となりますね？ そうでございます，私の間違えでした。左からです。 A B C D E 1 2 商品コード 商品名 分類コード 売上 廃棄 3 0200000011020 「大地の野菜」レタス 0010111101 3000 30 4 0000000000005 レタス 0010111101 ・ 5 0200000020047 国産和牛バラ肉カルビ焼用 0020131301 ・ 6 0200000020051 国産和牛肩バラ肉切落し 0020131301 ・ 7 0200000030048 まぐろたたき 0030151501 ・ 8 0200000030050 ネギトロ 0030151501 ・ 9 4903110059011 １・２便サンドＲ女峰苺Ｇ＆Ｍ 0040191902 ・ : 4903110021322 １・２便 あんぱん 0040191902 ・ : 4973330000018 徳用餃子 ２０粒 0050232308 ・ : 4901003501272 ごぼうサラダ ２７０ｇ 0050232309 ・ : 4971658116367 涼彩小鉢ざるうどん１２０Ｇ 0060262614 ・ : 0200000026368 チンジャオロース 0060262616 ・ : 4902466200153 海苔辛子 １１枚 0080636301 ・ : 0200000010010 若鶏唐揚 0190919101 ・ 合計 3000 30 こんな感じです。 C列の分類コードを下にシートごとに分けて１・２行の項目と最後の合計の行をそれぞれに付けたいのです。 これで，わかっていただけたでしょうか？不明な点があればまたおっしゃってください。 |
| ▼こうちゃん さん： すいません見にくかったのでもう一度送ります >こうちゃんさんおはようございます。 >またまたご面倒見ていただきありがとうございます。 > >>「10桁のうち右から３桁」ではなく「10桁のうち左から３桁」でいいんですか？ >>とすれば、判定が >>Loop While Left(Cells(行, 3), 3) = "001" >>となりますね？ > >そうでございます，私の間違えでした。左からです。 > A B C D E 1 2 商品コード 商品名 分類コード 売上 廃棄 3 0200000011020「大地の野菜」 0010111101 3000 30 4 0000000000005 レタス 0010111101 ・ 5 0200000020047 国産和牛バラ肉 0020131301 ・ 6 0200000020051 国産和牛肩バラ 0020131301 ・ 7 0200000030048 まぐろたたき 0030151501 ・ 8 0200000030050 ネギトロ 0030151501 ・ 9 4903110059011 １・２便サンド 0040191902 ・ : 4903110021322 １・２便 0040191902 ・ : 4973330000018 徳用餃子 ２０粒 0050232308 ・ : 4901003501272 ごぼうサラダ 0050232309 ・ : 4971658116367 涼彩小鉢ざる 0060262614 ・ : 0200000026368 チンジャオ 0060262616 ・ : 4902466200153 海苔辛子 0080636301 ・ : 0200000010010 若鶏唐揚 0190919101 ・ 合計 3000 30 こんな感じです。 C列の分類コードをもとにシートごとに分けて１・２行の項目と最後の合計の行をそれぞれに付けたいのです。 これで，わかっていただけたでしょうか？不明な点があればまたおっしゃってください。 |
| gori さん、こんにちは >> A B C D E >1 >2 商品コード 商品名 分類コード 売上 廃棄 >3 0200000011020「大地の野菜」 0010111101 3000 30 >4 0000000000005 レタス 0010111101 ・ >5 0200000020047 国産和牛バラ肉 0020131301 ・ >6 0200000020051 国産和牛肩バラ 0020131301 ・ >7 0200000030048 まぐろたたき 0030151501 ・ >8 0200000030050 ネギトロ 0030151501 ・ >9 4903110059011 １・２便サンド 0040191902 ・ >: 4903110021322 １・２便 0040191902 ・ >: 4973330000018 徳用餃子 ２０粒 0050232308 ・ >: 4901003501272 ごぼうサラダ 0050232309 ・ >: 4971658116367 涼彩小鉢ざる 0060262614 ・ >: 0200000026368 チンジャオ 0060262616 ・ >: 4902466200153 海苔辛子 0080636301 ・ >: 0200000010010 若鶏唐揚 0190919101 ・ > 合計 3000 30 > >こんな感じです。 >C列の分類コードをもとにシートごとに分けて１・２行の項目と最後の合計の行をそれぞれに付けたいのです。 >これで，わかっていただけたでしょうか？不明な点があればまたおっしゃってください。 理解力が不足していて申し訳ありません。 もしかするとまだわかっていないかもしれませんが・・・ C列の分類コードの左3桁が001〜006はそれぞれ各シートに、その他のコードのものは「その他」シートに行ごとにコピーする。 その際「Q_廃棄エクセルデータ」の1、2行目をヘッダとして各シートの1,2行目にコピーする。 さらに、売上（D）列と、廃棄（E）列にはデータ行の下に合計の計算式を設定したい。 ということでいいでしょうか？ goriさんの最初の質問の > 行 = 行 + 3 を見て、データは3行ずつセットだと思ってしまって、そのあとの私からの >>「Q_廃棄エクセルデータ」シートの2行目、3行目をヘッダ（項目名行）として、3行づつセットのデータがあります。 の質問を否定されなかったので、ずっと3行セットだと思ってました。 ということで、示されたデータの例を私なりに理解した形でコード書いてみました。 標準モジュールにコピペして実行してみてください。 Sub test() Dim TempClass As String Dim Srow As Long Dim Erow As Long Dim MaxRow As Long Dim ThisRow As Long Dim HeadRange As Range Dim MyRange As Range Dim ThisSheet As Worksheet Sheets.Add , Sheets(Sheets.Count) ActiveSheet.Name = "００１" Sheets.Add , Sheets(Sheets.Count) ActiveSheet.Name = "００２" Sheets.Add , Sheets(Sheets.Count) ActiveSheet.Name = "００３" Sheets.Add , Sheets(Sheets.Count) ActiveSheet.Name = "００４" Sheets.Add , Sheets(Sheets.Count) ActiveSheet.Name = "００５" Sheets.Add , Sheets(Sheets.Count) ActiveSheet.Name = "００６" Sheets.Add , Sheets(Sheets.Count) ActiveSheet.Name = "その他" Sheets("Q_廃棄エクセルデータ").Select Set HeadRange = Range("A1:A2").EntireRow MaxRow = Range("A65536").End(xlUp).Row ThisRow = 3 Srow = 3 TempClass = Left(Cells(ThisRow, 3).Value, 3) Do While ThisRow <= MaxRow If TempClass <> Left(Cells(ThisRow, 3).Value, 3) And TempClass <= "006" Then Set MyRange = Union(HeadRange, Range(Cells(Srow, 1), _ Cells(ThisRow - 1, 1)).EntireRow) MyRange.Copy Sheets(StrConv(TempClass, vbWide)).Cells(1, 1) Srow = ThisRow TempClass = Left(Cells(ThisRow, 3).Value, 3) End If ThisRow = ThisRow + 1 Loop Set MyRange = Union(HeadRange, Range(Cells(Srow, 1), Cells(ThisRow - 1, 1)).EntireRow) MyRange.Copy Sheets("その他").Cells(1, 1) For Each ThisSheet In Worksheets If (ThisSheet.Name >= "００１" And _ ThisSheet.Name <= "００６") Or _ ThisSheet.Name <= "その他" Then ThisRow = ThisSheet.Range("A65536").End(xlUp).Row + 1 ThisSheet.Cells(ThisRow, 3).Value = "合計" ThisSheet.Cells(ThisRow, 4).FormulaR1C1 = _ "=SUM(R[-" & ThisRow - 2 & "]C:R[-1]C)" ThisSheet.Cells(ThisRow, 5).FormulaR1C1 = _ "=SUM(R[-" & ThisRow - 2 & "]C:R[-1]C)" End If Next End Sub |
| ▼こうちゃん さん： 早速やってみましたが，うまくいきません。 >Sub test() > > Dim TempClass As String > Dim Srow As Long > Dim Erow As Long > Dim MaxRow As Long > Dim ThisRow As Long > Dim HeadRange As Range > Dim MyRange As Range > Dim ThisSheet As Worksheet > > Sheets.Add , Sheets(Sheets.Count) > ActiveSheet.Name = "００１" > Sheets.Add , Sheets(Sheets.Count) > ActiveSheet.Name = "００２" > Sheets.Add , Sheets(Sheets.Count) > ActiveSheet.Name = "００３" > Sheets.Add , Sheets(Sheets.Count) > ActiveSheet.Name = "００４" > Sheets.Add , Sheets(Sheets.Count) > ActiveSheet.Name = "００５" > Sheets.Add , Sheets(Sheets.Count) > ActiveSheet.Name = "００６" > Sheets.Add , Sheets(Sheets.Count) > ActiveSheet.Name = "その他" ここまではうまくいくんですが、その後シートごとにコピーされません（泣） そして，循環参照とか言うメッセージボックスが出てきてしまいます。 > Sheets("Q_廃棄エクセルデータ").Select > Set HeadRange = Range("A1:A2").EntireRow > MaxRow = Range("A65536").End(xlUp).Row > ThisRow = 3 > Srow = 3 > TempClass = Left(Cells(ThisRow, 3).Value, 3) > Do While ThisRow <= MaxRow > If TempClass <> Left(Cells(ThisRow, 3).Value, 3) And TempClass <= "006" Then > Set MyRange = Union(HeadRange, Range(Cells(Srow, 1), _ > Cells(ThisRow - 1, 1)).EntireRow) > MyRange.Copy Sheets(StrConv(TempClass, vbWide)).Cells(1, 1) > Srow = ThisRow > TempClass = Left(Cells(ThisRow, 3).Value, 3) > End If > ThisRow = ThisRow + 1 > Loop > > Set MyRange = Union(HeadRange, Range(Cells(Srow, 1), Cells(ThisRow - 1, 1)).EntireRow) > MyRange.Copy Sheets("その他").Cells(1, 1) > > For Each ThisSheet In Worksheets > If (ThisSheet.Name >= "００１" And _ > ThisSheet.Name <= "００６") Or _ > ThisSheet.Name <= "その他" Then > ThisRow = ThisSheet.Range("A65536").End(xlUp).Row + 1 > ThisSheet.Cells(ThisRow, 3).Value = "合計" > ThisSheet.Cells(ThisRow, 4).FormulaR1C1 = _ > "=SUM(R[-" & ThisRow - 2 & "]C:R[-1]C)" > ThisSheet.Cells(ThisRow, 5).FormulaR1C1 = _ > "=SUM(R[-" & ThisRow - 2 & "]C:R[-1]C)" > End If > Next > >End Sub |
| gori さん、こんばんは >▼こうちゃん さん： >早速やってみましたが，うまくいきません。 > >>Sub test() >> >> Dim TempClass As String >> Dim Srow As Long >> Dim Erow As Long >> Dim MaxRow As Long >> Dim ThisRow As Long >> Dim HeadRange As Range >> Dim MyRange As Range >> Dim ThisSheet As Worksheet >> >> Sheets.Add , Sheets(Sheets.Count) >> ActiveSheet.Name = "００１" >> Sheets.Add , Sheets(Sheets.Count) >> ActiveSheet.Name = "００２" >> Sheets.Add , Sheets(Sheets.Count) >> ActiveSheet.Name = "００３" >> Sheets.Add , Sheets(Sheets.Count) >> ActiveSheet.Name = "００４" >> Sheets.Add , Sheets(Sheets.Count) >> ActiveSheet.Name = "００５" >> Sheets.Add , Sheets(Sheets.Count) >> ActiveSheet.Name = "００６" >> Sheets.Add , Sheets(Sheets.Count) >> ActiveSheet.Name = "その他" >ここまではうまくいくんですが、その後シートごとにコピーされません（泣） >そして，循環参照とか言うメッセージボックスが出てきてしまいます。 私の書いた条件でいいんですか？違うところがありますか？ もし、違うところがあればもう少し詳細に教えてください。 goriさんのサンプルデータを使用して、当方でこのコードで試験したときは問題なく動いています。 ステップ実行して、どこでエラーが発生するか、確認してみていただけますか？ また途中で変数の値も予想と違わないか確認してみてください。 さらに「循環参照とか言う」ではなくエラーメッセージも正確に教えてください。 また、環境条件（Winの種別、ExcelのVersion等）も教えてください。 >> Sheets("Q_廃棄エクセルデータ").Select >> Set HeadRange = Range("A1:A2").EntireRow >> MaxRow = Range("A65536").End(xlUp).Row >> ThisRow = 3 >> Srow = 3 >> TempClass = Left(Cells(ThisRow, 3).Value, 3) >> Do While ThisRow <= MaxRow >> If TempClass <> Left(Cells(ThisRow, 3).Value, 3) And TempClass <= "006" Then >> Set MyRange = Union(HeadRange, Range(Cells(Srow, 1), _ >> Cells(ThisRow - 1, 1)).EntireRow) >> MyRange.Copy Sheets(StrConv(TempClass, vbWide)).Cells(1, 1) >> Srow = ThisRow >> TempClass = Left(Cells(ThisRow, 3).Value, 3) >> End If >> ThisRow = ThisRow + 1 >> Loop >> >> Set MyRange = Union(HeadRange, Range(Cells(Srow, 1), Cells(ThisRow - 1, 1)).EntireRow) >> MyRange.Copy Sheets("その他").Cells(1, 1) >> >> For Each ThisSheet In Worksheets >> If (ThisSheet.Name >= "００１" And _ >> ThisSheet.Name <= "００６") Or _ >> ThisSheet.Name <= "その他" Then >> ThisRow = ThisSheet.Range("A65536").End(xlUp).Row + 1 >> ThisSheet.Cells(ThisRow, 3).Value = "合計" >> ThisSheet.Cells(ThisRow, 4).FormulaR1C1 = _ >> "=SUM(R[-" & ThisRow - 2 & "]C:R[-1]C)" >> ThisSheet.Cells(ThisRow, 5).FormulaR1C1 = _ >> "=SUM(R[-" & ThisRow - 2 & "]C:R[-1]C)" >> End If >> Next >> >>End Sub |
| ▼こうちゃん さん： こうちゃんさん早速返事いただきありがとうございます。 いつも言葉すくなですいません。 >私の書いた条件でいいんですか？違うところがありますか？ >もし、違うところがあればもう少し詳細に教えてください。 こうちゃんさんの書いた条件で大丈夫です。 >goriさんのサンプルデータを使用して、当方でこのコードで試験したときは問題なく動いています。 > >ステップ実行して、どこでエラーが発生するか、確認してみていただけますか？ エラーは発生していないのです。 >また途中で変数の値も予想と違わないか確認してみてください。 >さらに「循環参照とか言う」ではなくエラーメッセージも正確に教えてください。 分類のシートごとにコピーされているのではなく、その他に全部コピーされているのです。 最終行の合計式だけが各分類のシートにつけられて、プログラム終了後 循環参照というメッセージボックスが表示されます。 >また、環境条件（Winの種別、ExcelのVersion等）も教えてください。 Windows2000 Professional,Excel2000(Office2000)です。 甘えてばかりいてすいません。 >>> Sheets("Q_廃棄エクセルデータ").Select >>> Set HeadRange = Range("A1:A2").EntireRow >>> MaxRow = Range("A65536").End(xlUp).Row >>> ThisRow = 3 >>> Srow = 3 >>> TempClass = Left(Cells(ThisRow, 3).Value, 3) >>> Do While ThisRow <= MaxRow >>> If TempClass <> Left(Cells(ThisRow, 3).Value, 3) And TempClass <= "006" Then >>> Set MyRange = Union(HeadRange, Range(Cells(Srow, 1), _ >>> Cells(ThisRow - 1, 1)).EntireRow) >>> MyRange.Copy Sheets(StrConv(TempClass, vbWide)).Cells(1, 1) >>> Srow = ThisRow >>> TempClass = Left(Cells(ThisRow, 3).Value, 3) >>> End If >>> ThisRow = ThisRow + 1 >>> Loop >>> >>> Set MyRange = Union(HeadRange, Range(Cells(Srow, 1), Cells(ThisRow - 1, 1)).EntireRow) >>> MyRange.Copy Sheets("その他").Cells(1, 1) >>> >>> For Each ThisSheet In Worksheets >>> If (ThisSheet.Name >= "００１" And _ >>> ThisSheet.Name <= "００６") Or _ >>> ThisSheet.Name <= "その他" Then >>> ThisRow = ThisSheet.Range("A65536").End(xlUp).Row + 1 >>> ThisSheet.Cells(ThisRow, 3).Value = "合計" >>> ThisSheet.Cells(ThisRow, 4).FormulaR1C1 = _ >>> "=SUM(R[-" & ThisRow - 2 & "]C:R[-1]C)" >>> ThisSheet.Cells(ThisRow, 5).FormulaR1C1 = _ >>> "=SUM(R[-" & ThisRow - 2 & "]C:R[-1]C)" >>> End If >>> Next >>> >>>End Sub |
| gori さん、こんにちは 1.分類コード列のデータは、文字列か？ 書式で文字列表示にしていないか？実際に"0010111101"のようなものになっているか？ 2.分類コード列はコード順にならんでいるか？ 1.で文字列でない場合はコードが変わってきます。 現在のコードではgoriさんのおっしゃるような「循環参照」の可能性もあります。 2.の場合で3行目のデータの分類コードが"001*******”〜"006*******”以外のものである場合は「その他」シートにすべてのデータがコピーされます。 ＃当方で再現できませんので、よろしければgoriさんが試験している実データを送ってみていただけませんか？（もちろん金額等はダミーでもいいのですが・・） ＃合計の計算式の設定にミスがありました。計算式の設定部分を下記コードに変更してください。 For Each ThisSheet In Worksheets If (ThisSheet.Name >= "００１" And _ ThisSheet.Name <= "００６") Or _ ThisSheet.Name <= "その他" Then ThisRow = ThisSheet.Range("A65536").End(xlUp).Row + 1 If ThisRow > 4 Then ThisSheet.Cells(ThisRow, 3).Value = "合計" ThisSheet.Cells(ThisRow, 4).FormulaR1C1 = "=SUM(R[-" & ThisRow - 3 & "]C:R[-1]C)" ThisSheet.Cells(ThisRow, 5).FormulaR1C1 = "=SUM(R[-" & ThisRow - 3 & "]C:R[-1]C)" End If End If Next |
| ▼こうちゃん さん： こうちゃんさん，お世話かけすぎですいません。 > >1.分類コード列のデータは、文字列か？ >書式で文字列表示にしていないか？実際に"0010111101"のようなものになっているか？ >2.分類コード列はコード順にならんでいるか？ >1.で文字列でない場合はコードが変わってきます。 >現在のコードではgoriさんのおっしゃるような「循環参照」の可能性もあります。 アクセスからはきだしているのですが，元のテーブルを見ても型はテキストになってます。 >2.の場合で3行目のデータの分類コードが"001*******”〜"006*******”以外のものである場合は「その他」シートにすべてのデータがコピーされます。 順に並んでいます。 >＃当方で再現できませんので、よろしければgoriさんが試験している実データを送ってみていただけませんか？（もちろん金額等はダミーでもいいのですが・・） 設定でメールが開けませんので，すいませんお手数ですが私のメールにアドレスを送っていただけませんでしょうか。 >＃合計の計算式の設定にミスがありました。計算式の設定部分を下記コードに変更してください。 > > For Each ThisSheet In Worksheets > If (ThisSheet.Name >= "００１" And _ > ThisSheet.Name <= "００６") Or _ > ThisSheet.Name <= "その他" Then > ThisRow = ThisSheet.Range("A65536").End(xlUp).Row + 1 > If ThisRow > 4 Then > ThisSheet.Cells(ThisRow, 3).Value = "合計" > ThisSheet.Cells(ThisRow, 4).FormulaR1C1 = "=SUM(R[-" & ThisRow - 3 & "]C:R[-1]C)" > ThisSheet.Cells(ThisRow, 5).FormulaR1C1 = "=SUM(R[-" & ThisRow - 3 & "]C:R[-1]C)" > End If > End If > Next 勝手ばかり申し上げて，すいません。 よろしくお願い致します。 |
| goriさん、こんにちは 送ってもらったBookを確認しましたが、Bookが不正なようです。 原因はまだ判明しませんが、現象としては以下のとおりです。 1.フォントがMSゴシックと表示されているが、シートを見ると明朝で表示されている。 2.いずれかのセルを編集して、Enter押下すると文字化けする。 3.前レスのコードを実行すると「循環参照」フォームが表示されるが、循環先等はみつからない。データもコードどおりにはコピーされない。 対策としては、 1.「Q_廃棄エクセルデータ.xls」のデータをコピーする。（クリップボード） 2.新規Bookの新規シートに「形式を指定してコピー」（値）する。 で正常なBookを作って、コードを実行すればエラーは発生しません。 なお、データ行が2行目から始まっていますので、前レスのコードは1部手直しが必要です。 前記対策を含めてコードを検討しますので、ちょっとお時間くださいね。 |
| goriさん、こんにちは やはり原因は特定できませんでした。 対策コードを書いてみましたので試験してみてください。 新しいBookを「Q_廃棄エクセルデータ.xls」と同じフォルダに作成してください。 Book名は任意です。（シートは1枚でもOK） 以下のプロシージャを標準モジュールに貼ります。 Mainを実行してください。 Sub Main() Call DataCopy Call Classify End Sub Sub DataCopy() Dim MyBook As Workbook Dim Q_Book As Workbook Dim ThisSheet As Worksheet Set MyBook = ActiveWorkbook Application.ScreenUpdating = False '前処理・1番目のシートデータをクリア MyBook.Sheets(1).Cells.ClearContents '001〜006とその他シート削除 Application.DisplayAlerts = False For Each ThisSheet In Worksheets If (ThisSheet.Name >= "001" And _ ThisSheet.Name <= "006") Or _ ThisSheet.Name = "その他" Then ThisSheet.Delete End If Next Application.DisplayAlerts = True 'Q_廃棄エクセルデータ.xlsを開く Set Q_Book = Workbooks.Open(Filename:=MyBook.Path & "\Q_廃棄エクセルデータ.xls") 'Q_廃棄エクセルデータ.xlsの1番目のシートをコピー Q_Book.Sheets(1).Cells.Copy 'このBookの1番目のシートに値貼り付け MyBook.Sheets(1).Cells.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _ False, Transpose:=False 'Q_廃棄エクセルデータ.xlsを閉じる Application.CutCopyMode = False Q_Book.Close MyBook.Sheets(1).Name = "Q_廃棄エクセルデータ" Application.ScreenUpdating = True Set Q_Book = Nothing Set MyBook = Nothing End Sub Sub Classify() Dim TempClass As String Dim Srow As Long Dim Erow As Long Dim MaxRow As Long Dim ThisRow As Long Dim HeadRange As Range Dim MyRange As Range Dim ThisSheet As Worksheet Dim i As Integer Dim j As Integer Application.ScreenUpdating = False Sheets.Add , Sheets(Sheets.Count) ActiveSheet.Name = "001" Sheets.Add , Sheets(Sheets.Count) ActiveSheet.Name = "002" Sheets.Add , Sheets(Sheets.Count) ActiveSheet.Name = "003" Sheets.Add , Sheets(Sheets.Count) ActiveSheet.Name = "004" Sheets.Add , Sheets(Sheets.Count) ActiveSheet.Name = "005" Sheets.Add , Sheets(Sheets.Count) ActiveSheet.Name = "006" Sheets.Add , Sheets(Sheets.Count) ActiveSheet.Name = "その他" Sheets("Q_廃棄エクセルデータ").Select Set HeadRange = Rows(1) MaxRow = Range("A65536").End(xlUp).Row ThisRow = 2 Srow = 2 '2行目のC列の3桁を保持 TempClass = Left(Cells(ThisRow, 3).Value, 3) 'データを最後までループ Do While ThisRow <= MaxRow If TempClass <> Left(Cells(ThisRow, 3).Value, 3) And TempClass <= "006" Then 'TempClassと分類コードが違ったらそこまでの行をクリップボードにコピー Set MyRange = Union(HeadRange, Range(Cells(Srow, 1), _ Cells(ThisRow - 1, 1)).EntireRow) '該当の分類シートの3行目以降にコピー MyRange.Copy Sheets(TempClass).Cells(3, 1) Srow = ThisRow TempClass = Left(Cells(ThisRow, 3).Value, 3) End If ThisRow = ThisRow + 1 Loop '分類コード006以降を「その他」シートにコピー Set MyRange = Union(HeadRange, Range(Cells(Srow, 1), Cells(ThisRow - 1, 1)).EntireRow) MyRange.Copy Sheets("その他").Cells(3, 1) For Each ThisSheet In Worksheets If (ThisSheet.Name >= "001" And _ ThisSheet.Name <= "006") Or _ ThisSheet.Name = "その他" Then ThisRow = ThisSheet.Range("A65536").End(xlUp).Row + 1 '合計計算式設定 If ThisRow > 4 Then ThisSheet.Cells(ThisRow, 4).FormulaR1C1 = "=SUM(R[-" & ThisRow - 3 & "]C:R[-1]C)" ThisSheet.Cells(ThisRow, 5).FormulaR1C1 = "=SUM(R[-" & ThisRow - 3 & "]C:R[-1]C)" '合計計算式コピー ThisSheet.Select Range(Cells(ThisRow, 4), Cells(ThisRow, 5)).Copy Range("H" & ThisRow & ",L" & ThisRow & ",P" & ThisRow & _ ",T" & ThisRow & ",X" & ThisRow & ",AB" & ThisRow & _ ",AF" & ThisRow & ",AJ" & ThisRow & ",AN" & ThisRow & _ ",AR" & ThisRow & ",AV" & ThisRow & ",AZ" & ThisRow).Select ActiveSheet.Paste '廃棄率欄作成 Range("H:I,L:M,P:Q,T:U,X:Y,AB:AC,AF:AG,AJ:AK,AN:AO,AR:AS,AV:AW,AZ:BA").Select Application.CutCopyMode = False Selection.Insert Shift:=xlToRight '項目名の補正 Cells(3, 1).Value = "商品コード" Cells(3, 2).Value = "商品名" For i = 4 To 70 Step 6 Cells(2, i).Value = "'" & Left(Cells(3, i).Value, 3) For j = 0 To 3 Cells(3, i + j).Value = Right(Cells(3, i + j).Value, 4) Next Cells(2, i + 4).Value = "廃棄率" Cells(3, i + 4).Value = "金額" Cells(3, i + 5).Value = "点数" Next '罫線(大体のところだけです。ちゃんと補正してください） Range("A2:CA3").Select Selection.Borders(xlDiagonalDown).LineStyle = xlNone Selection.Borders(xlDiagonalUp).LineStyle = xlNone With Selection.Borders(xlEdgeLeft) .LineStyle = xlContinuous .Weight = xlThin .ColorIndex = xlAutomatic End With With Selection.Borders(xlEdgeTop) .LineStyle = xlContinuous .Weight = xlThin .ColorIndex = xlAutomatic End With With Selection.Borders(xlEdgeBottom) .LineStyle = xlContinuous .Weight = xlThin .ColorIndex = xlAutomatic End With With Selection.Borders(xlEdgeRight) .LineStyle = xlContinuous .Weight = xlThin .ColorIndex = xlAutomatic End With Range("D3:CA3").Select Selection.Borders(xlDiagonalDown).LineStyle = xlNone Selection.Borders(xlDiagonalUp).LineStyle = xlNone With Selection.Borders(xlEdgeLeft) .LineStyle = xlContinuous .Weight = xlThin .ColorIndex = xlAutomatic End With With Selection.Borders(xlEdgeTop) .LineStyle = xlContinuous .Weight = xlThin .ColorIndex = xlAutomatic End With With Selection.Borders(xlEdgeBottom) .LineStyle = xlContinuous .Weight = xlThin .ColorIndex = xlAutomatic End With With Selection.Borders(xlEdgeRight) .LineStyle = xlContinuous .Weight = xlThin .ColorIndex = xlAutomatic End With With Selection.Borders(xlInsideVertical) .LineStyle = xlContinuous .Weight = xlThin .ColorIndex = xlAutomatic End With Range("A4:CA" & ThisRow).Select Selection.Borders(xlDiagonalDown).LineStyle = xlNone Selection.Borders(xlDiagonalUp).LineStyle = xlNone With Selection.Borders(xlEdgeLeft) .LineStyle = xlContinuous .Weight = xlThin .ColorIndex = xlAutomatic End With With Selection.Borders(xlEdgeTop) .LineStyle = xlContinuous .Weight = xlThin .ColorIndex = xlAutomatic End With With Selection.Borders(xlEdgeBottom) .LineStyle = xlContinuous .Weight = xlThin .ColorIndex = xlAutomatic End With With Selection.Borders(xlEdgeRight) .LineStyle = xlContinuous .Weight = xlThin .ColorIndex = xlAutomatic End With With Selection.Borders(xlInsideVertical) .LineStyle = xlContinuous .Weight = xlThin .ColorIndex = xlAutomatic End With With Selection.Borders(xlInsideHorizontal) .LineStyle = xlContinuous .Weight = xlThin .ColorIndex = xlAutomatic End With '項目色つけ Range("A2:CA3").Select With Selection.Interior .ColorIndex = 15 .Pattern = xlSolid End With 'A〜C列オートフィット Columns("A:C").EntireColumn.AutoFit End If Range("A1").Select End If Next Application.ScreenUpdating = True End Sub |
| ▼こうちゃん さん： ありがとうございました。 早速実行させていただきました。 長々とご迷惑をかけ本当に申し訳ありませんでした。 またわからないことがあったら質問させていただきます。 |