Excel VBA質問箱 IV

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

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


7412 / 13644 ツリー ←次へ | 前へ→

【38305】セル情報ごと 新book書き出し 初心者 06/5/31(水) 10:04 発言[未読]
【38308】Re:セル情報ごと 新book書き出し Statis 06/5/31(水) 10:23 発言[未読]
【38310】Re:セル情報ごと 新book書き出し 初心者 06/5/31(水) 10:41 回答[未読]
【38312】Re:セル情報ごと 新book書き出し Statis 06/5/31(水) 11:00 回答[未読]
【38316】Re:セル情報ごと 新book書き出し 初心者 06/5/31(水) 11:18 回答[未読]
【38318】Re:セル情報ごと 新book書き出し Statis 06/5/31(水) 11:36 発言[未読]
【38321】Re:セル情報ごと 新book書き出し 初心者 06/5/31(水) 12:39 回答[未読]
【38323】Re:セル情報ごと 新book書き出し Statis 06/5/31(水) 12:43 発言[未読]
【38326】Re:セル情報ごと 新book書き出し 初心者 06/5/31(水) 13:28 発言[未読]
【38373】Re:セル情報ごと 新book書き出し Statis 06/6/1(木) 9:23 発言[未読]
【38603】Re:セル情報ごと 新book書き出し 初心者 06/6/7(水) 9:42 回答[未読]
【38604】Re:セル情報ごと 新book書き出し Statis 06/6/7(水) 10:01 回答[未読]
【38617】Re:セル情報ごと 新book書き出し 初心者 06/6/7(水) 13:45 回答[未読]
【38619】Re:セル情報ごと 新book書き出し Statis 06/6/7(水) 14:50 発言[未読]
【38750】Re:セル情報ごと 新book書き出し 初心者 06/6/9(金) 12:00 発言[未読]
【38812】Re:セル情報ごと 新book書き出し Statis 06/6/11(日) 8:20 発言[未読]
【38846】Re:セル情報ごと 新book書き出し 初心者 06/6/12(月) 13:43 発言[未読]
【38875】Re:セル情報ごと 新book書き出し Statis 06/6/13(火) 12:38 発言[未読]
【38880】Re:セル情報ごと 新book書き出し 初心 06/6/13(火) 16:50 発言[未読]
【38882】Re:セル情報ごと 新book書き出し Statis 06/6/13(火) 16:57 発言[未読]
【38907】Re:セル情報ごと 新book書き出し 初心 06/6/14(水) 10:05 発言[未読]
【38922】Re:セル情報ごと 新book書き出し Statis 06/6/14(水) 13:30 回答[未読]
【39021】Re:セル情報ごと 新book書き出し 初心者 06/6/16(金) 9:46 発言[未読]
【39030】Re:セル情報ごと 新book書き出し Statis 06/6/16(金) 11:19 回答[未読]
【39053】Re:セル情報ごと 新book書き出し 初心者 06/6/16(金) 16:58 発言[未読]
【39054】Re:セル情報ごと 新book書き出し Statis 06/6/16(金) 17:01 発言[未読]
【39238】Re:セル情報ごと 新book書き出し 初心者 06/6/20(火) 12:52 発言[未読]
【39240】Re:セル情報ごと 新book書き出し Statis 06/6/20(火) 13:01 回答[未読]
【39248】Re:セル情報ごと 新book書き出し 初心者 06/6/20(火) 14:55 発言[未読]
【39278】Re:セル情報ごと 新book書き出し Statis 06/6/21(水) 8:22 発言[未読]
【39286】Re:セル情報ごと 新book書き出し 初心者 06/6/21(水) 13:00 発言[未読]
【39310】Re:セル情報ごと 新book書き出し Statis 06/6/22(木) 9:29 発言[未読]

【38305】セル情報ごと 新book書き出し
発言  初心者  - 06/5/31(水) 10:04 -

引用なし
パスワード
   元BookのH列のオートフィルタにより
各値ごと新bookへ書き出し 1行目削除
AB列で並び替え 
AB列並び替え後 不要なので削除
F列情報をシート名としコピー


上記を 元bookよりF列情報が幾つかあるので
繰り返したいのですが
元Book名は 毎回変わり
F列情報も其の度変わりますので
下記途中までですが マクロ登録したものを
使い loopで F列の情報が
全て それぞれ各新bookに出るまで 続けたいのですが
どうしたら良いのか?です。
 
Selection.AutoFilter Field:=8, Criteria1:="A"
  Cells.Select
  Selection.Copy
  Workbooks.Add
  Cells.Select
  ActiveSheet.Paste
  Rows("1:1").Select
  Application.CutCopyMode = False
  Selection.Delete Shift:=xlUp
  Cells.Select
  Selection.Sort Key1:=Range("A1"), Order1:=xlAscending, Key2:=Range("B1") _
    , Order2:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:= _
    False, Orientation:=xlTopToBottom, SortMethod:=xlPinYin, DataOption1:= _
    xlSortNormal, DataOption2:=xlSortTextAsNumbers
  Columns("A:B").Select
  Range("B1").Activate
  Selection.Delete Shift:=xlToLeft
  Range("F1").Select
  Selection.Copy
  Sheets("Sheet1").Select
  Sheets("Sheet1").Name = "A"
  Cells.Select
  Cells.EntireColumn.AutoFit
  Windows("K.CSV").Activate

情報をうまく説明できず申し訳ないのですが
どなたか 教えて頂けると助かります
宜しくお願い致します

【38308】Re:セル情報ごと 新book書き出し
発言  Statis  - 06/5/31(水) 10:23 -

引用なし
パスワード
   こんにちは

新規Bookを一つ作りF列の値(重複は除く)シートを作成し
そのシート名を抽出した値にしてデータを転記し行、列の削除や並び替えを
したいと言う事でしょうか?

【38310】Re:セル情報ごと 新book書き出し
回答  初心者  - 06/5/31(水) 10:41 -

引用なし
パスワード
   ▼Statis さん:
>こんにちは
>
>新規Bookを一つ作りF列の値(重複は除く)シートを作成し
          上記各1つの情報で出来ています
            F(列)
          例 空 がF2:F4 F301:502
            T が F5:F150
            B が F151:F200
            J が F201:F300 等です
            F が F501:506
 空セルは無視 情報の入っている行のみ 同じ値をフィルターにて抽出          
 
>そのシート名を抽出した値にしてデータを転記し
>行、列の削除や並び替えをしたいと言う事でしょうか?
 その通りです
F列 情報が T ならば
Tの情報全て1bookにまとめ AB列にて昇順(数値に見えるにチェック)
そのTをシート名として取り AB昇順に並んだらAB列不要になるので消去

上記を 元bookから新book 1seet もしくは 新book それぞれ各sheetとして
分けたいです

【38312】Re:セル情報ごと 新book書き出し
回答  Statis  - 06/5/31(水) 11:00 -

引用なし
パスワード
   こんにちは


下記のコードを新規ファイルに記載して下さい。

コードを実行すると「csv」ファイルの選択になりますので該当ファイルを
探し選択して下さい。
新規ファイルが自動的に出来、そのファイルにH列の各値のシートが出来て
オートフィルタで抽出したデータがコピーされ並び替え、列の削除を行います。

一度試してみて下さい。(結果を報告願います)

Sub Test()
Dim MyFil As String, Wb As Workbook, Ws As Worksheet
Dim NowWb As Workbook, NowWs As Worksheet, C As Range

MyFil = Application.GetOpenFilename("テキスト ファイル (*.csv), *.csv")
If MyFil = "False" Then Exit Sub
Application.ScreenUpdating = False
Set Ws = ThisWorkbook.Worksheets("Sheet1")
Set NowWb = Workbooks.Add(1)
Set Wb = Workbooks.Open(MyFil)
With Wb.ActiveSheet
   .Columns(8).AdvancedFilter xlFilterCopy, , Ws.Range("A1"), True
   .Rows(1).AutoFilter
   For Each C In Ws.Range("A2", Ws.Range("A65536").End(xlUp))
     .Columns(8).AutoFilter 8, C.Value
     Set NowWs = NowWb.Worksheets.Add
     NowWs.Name = C.Value
     .AutoFilter.Range.Copy NowWs.Range("A1")
     With NowWs
       .Rows(1).Delete
       .UsedRange.Sort Key1:=.Range("A1"), Order1:=xlAscending, Key2:=.Range("B1") _
       , Order2:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:= _
       False, Orientation:=xlTopToBottom, SortMethod:=xlPinYin, DataOption1:= _
       xlSortNormal, DataOption2:=xlSortTextAsNumbers
       .Columns("A:B").Delete
       .Cells.EntireColumn.AutoFit
     End With
     Set NowWs = Nothing
   Next C
   .AutoFilterMode = False
End With
Ws.Columns(1).Clear
Wb.Close False
With Application
   .DisplayAlerts = False
   NowWb.Sheets("Sheet1").Delete
   .DisplayAlerts = True
   .ScreenUpdating = True
End With
Set NowWb = Nothing: Set Ws = Nothing: Set Wb = Nothing
End Sub

【38316】Re:セル情報ごと 新book書き出し
回答  初心者  - 06/5/31(水) 11:18 -

引用なし
パスワード
   ▼Statis さん:
>こんにちは
>
>
>下記のコードを新規ファイルに記載して下さい。
>
>コードを実行すると「csv」ファイルの選択になりますので該当ファイルを
>探し選択して下さい。
>新規ファイルが自動的に出来、そのファイルにH列の各値のシートが出来て
>オートフィルタで抽出したデータがコピーされ並び替え、列の削除を行います。
>
>一度試してみて下さい。(結果を報告願います)
>
>Sub Test()
>Dim MyFil As String, Wb As Workbook, Ws As Worksheet
>Dim NowWb As Workbook, NowWs As Worksheet, C As Range
>
>MyFil = Application.GetOpenFilename("テキスト ファイル (*.csv), *.csv")
>If MyFil = "False" Then Exit Sub
>Application.ScreenUpdating = False
>Set Ws = ThisWorkbook.Worksheets("Sheet1")
>Set NowWb = Workbooks.Add(1)
>Set Wb = Workbooks.Open(MyFil)
>With Wb.ActiveSheet
>   .Columns(8).AdvancedFilter xlFilterCopy, , Ws.Range("A1"), True
>   .Rows(1).AutoFilter
>   For Each C In Ws.Range("A2", Ws.Range("A65536").End(xlUp))
>     .Columns(8).AutoFilter 8, C.Value
>     Set NowWs = NowWb.Worksheets.Add
>     NowWs.Name = C.Value
>     .AutoFilter.Range.Copy NowWs.Range("A1")
>     With NowWs
>       .Rows(1).Delete
>       .UsedRange.Sort Key1:=.Range("A1"), Order1:=xlAscending, Key2:=.Range("B1") _
>       , Order2:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:= _
>       False, Orientation:=xlTopToBottom, SortMethod:=xlPinYin, DataOption1:= _
>       xlSortNormal, DataOption2:=xlSortTextAsNumbers
>       .Columns("A:B").Delete
>       .Cells.EntireColumn.AutoFit
>     End With
>     Set NowWs = Nothing
>   Next C
>   .AutoFilterMode = False
>End With
>Ws.Columns(1).Clear
>Wb.Close False
>With Application
>   .DisplayAlerts = False
>   NowWb.Sheets("Sheet1").Delete
>   .DisplayAlerts = True
>   .ScreenUpdating = True
>End With
>Set NowWb = Nothing: Set Ws = Nothing: Set Wb = Nothing
>End Sub


 有難う御座います
ただ それぞれに 既にシート名が振ってあるため
Set Ws = ThisWorkbook.Worksheets("Sheet1")
上記で止まってしまいます。。

【38318】Re:セル情報ごと 新book書き出し
発言  Statis  - 06/5/31(水) 11:36 -

引用なし
パスワード
   こんにちは

私の記載して通り実行しましたか?
>>下記のコードを新規ファイルに記載して下さい。

>>コードを実行すると「csv」ファイルの選択になりますので該当ファイルを
>>探し選択して下さい。
>>新規ファイルが自動的に出来、そのファイルにH列の各値のシートが出来て
>>オートフィルタで抽出したデータがコピーされ並び替え、列の削除を行います。

と言う事で「CSV」ファイルの選択以外は自動で出来るはずですが?

>ただ それぞれに 既にシート名が振ってあるため
事前作業なしです。
ただ、事前に出来ているシートに追加して行くのなら別ですが?
質問内容とは違ってきますが。

【38321】Re:セル情報ごと 新book書き出し
回答  初心者  - 06/5/31(水) 12:39 -

引用なし
パスワード
   ▼Statis さん:
こんにちは

>私の記載して通り実行しましたか?
>>>下記のコードを新規ファイルに記載して下さい。
>
>>>コードを実行すると「csv」ファイルの選択になりますので該当ファイルを
>>>探し選択して下さい。
>>>新規ファイルが自動的に出来、そのファイルにH列の各値のシートが出来て
>>>オートフィルタで抽出したデータがコピーされ並び替え、列の削除を行います。
>
>と言う事で「CSV」ファイルの選択以外は自動で出来るはずですが?

 上記勘違いしてました すいませんでした

新bookにtestマクロを入れ作動させたところ
NowWs.Name = C.Value
の ところで 止まります。

何度も申し訳ありません

【38323】Re:セル情報ごと 新book書き出し
発言  Statis  - 06/5/31(水) 12:43 -

引用なし
パスワード
   こんにちは

>新bookにtestマクロを入れ作動させたところ
>NowWs.Name = C.Value
>の ところで 止まります。

Errが出ると言う事ですか?
そのErr内容は何でしょう?
(シート名に出来ない文字や記号がH列に含まれてはいないですよね)

【38326】Re:セル情報ごと 新book書き出し
発言  初心者  - 06/5/31(水) 13:28 -

引用なし
パスワード
   ▼Statis さん:
>こんにちは
>
>>新bookにtestマクロを入れ作動させたところ
>>NowWs.Name = C.Value
>>の ところで 止まります。
>
>Errが出ると言う事ですか?
>そのErr内容は何でしょう?
>(シート名に出来ない文字や記号がH列に含まれてはいないですよね)

 何度もすいません
NAMEメゾネット失敗:Worksheetオブジェクト
H列情報をコピー:ペーストで
シート名を入れましたが 問題は出ていません。
何も解らず 本当に申し訳ないです

【38373】Re:セル情報ごと 新book書き出し
発言  Statis  - 06/6/1(木) 9:23 -

引用なし
パスワード
   こんにちは
遅くなりました。
シート名になる値を確認してみましょう。

「.Rows(1).AutoFilter」←ここでブレークポイントを設定し
コードが実行。上記で止まりますので。
コードの書いてあるファイルのSheet1のA列の値を確認して下さい。
そのデータが抽出されてシート名のなる値です(実際はA2からのデータです)

【38603】Re:セル情報ごと 新book書き出し
回答  初心者  - 06/6/7(水) 9:42 -

引用なし
パスワード
   ▼Statis さん:
>こんにちは
>遅くなりました。
>シート名になる値を確認してみましょう。
>
>「.Rows(1).AutoFilter」←ここでブレークポイントを設定し
>コードが実行。上記で止まりますので。
>コードの書いてあるファイルのSheet1のA列の値を確認して下さい。
>そのデータが抽出されてシート名のなる値です(実際はA2からのデータです)

Statis さん
 有難う御座います
ブレークポイントがよく分かりませんでしたが
出来ました。
其の時点で
A1に見出し
A3よりA列にそれぞれの値が抽出されております。
宜しくお願い致します。

【38604】Re:セル情報ごと 新book書き出し
回答  Statis  - 06/6/7(水) 10:01 -

引用なし
パスワード
   こんにちは

これで如何でしょうか?

Sub Test()
Dim MyFil As String, Wb As Workbook, Ws As Worksheet
Dim NowWb As Workbook, NowWs As Worksheet, C As Range

MyFil = Application.GetOpenFilename("テキスト ファイル (*.csv), *.csv")
If MyFil = "False" Then Exit Sub
Application.ScreenUpdating = False
Set Ws = ThisWorkbook.Worksheets("Sheet1")
Set NowWb = Workbooks.Add(1)
Set Wb = Workbooks.Open(MyFil)
With Wb.ActiveSheet
   .Columns(8).AdvancedFilter xlFilterCopy, , Ws.Range("A1"), True
   .Rows(1).AutoFilter
   For Each C In Ws.Range("A2", Ws.Range("A65536").End(xlUp))
     If Not IsEmpty(C.Value) Then
      .Columns(8).AutoFilter 8, C.Value
      Set NowWs = NowWb.Worksheets.Add
      NowWs.Name = C.Value
      .AutoFilter.Range.Copy NowWs.Range("A1")
      With NowWs
        .Rows(1).Delete
        .UsedRange.Sort Key1:=.Range("A1"), Order1:=xlAscending, Key2:=.Range("B1") _
          , Order2:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:=False _
          , Orientation:=xlTopToBottom, SortMethod:=xlPinYin, DataOption1:=xlSortNormal _
          , DataOption2:=xlSortTextAsNumbers
        .Columns("A:B").Delete
        .Cells.EntireColumn.AutoFit
      End With
      Set NowWs = Nothing
     End If
   Next C
   .AutoFilterMode = False
End With
Ws.Columns(1).Clear
Wb.Close False
With Application
   .DisplayAlerts = False
   NowWb.Sheets("Sheet1").Delete
   .DisplayAlerts = True
   .ScreenUpdating = True
End With
Set NowWb = Nothing: Set Ws = Nothing: Set Wb = Nothing
End Sub

【38617】Re:セル情報ごと 新book書き出し
回答  初心者  - 06/6/7(水) 13:45 -

引用なし
パスワード
   ▼Statis さん:
こんにちは  有難う御座います
 .UsedRange.Sort Key1:=.Range("A1"), Order1:=xlAscending, Key2:=.Range("B1") _
          , Order2:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:=False _
          , Orientation:=xlTopToBottom, SortMethod:=xlPinYin, DataOption1:=xlSortNormal _
          , DataOption2:=xlSortTextAsNumbers

上記でRangeクラスSortメゾネットエラーとなります

Statis さん
まるでVBAが読めず分からないのですが
こちらは
シートに名前を書き出すのみでしょうか?
それとも
元CSVより
行全ての情報がそれぞれのシートに最終的には書き出されますか?

【38619】Re:セル情報ごと 新book書き出し
発言  Statis  - 06/6/7(水) 14:50 -

引用なし
パスワード
    こんにちは
>元CSVより
>行全ての情報がそれぞれのシートに最終的には書き出されますか?

Errのところでデータが無い言う事ですね?

ならおかしいですね?
では確認です。下記のコードの「.Columns(8).AutoFilter 8, C.Value」で
ブレークポイントを設定しコードを実行上記で止まったら「F8」でコードを
進めてオートフィルタで抽出されているかさらに進めてシートのコピーされているかを各シートで確認して下さい。


Sub Test()
Dim MyFil As String, Wb As Workbook, Ws As Worksheet
Dim NowWb As Workbook, NowWs As Worksheet, C As Range

MyFil = Application.GetOpenFilename("テキスト ファイル (*.csv), *.csv")
If MyFil = "False" Then Exit Sub
Application.ScreenUpdating = False
Set Ws = ThisWorkbook.Worksheets("Sheet1")
Set NowWb = Workbooks.Add(1)
Set Wb = Workbooks.Open(MyFil)
With Wb.ActiveSheet
   .Columns(8).AdvancedFilter xlFilterCopy, , Ws.Range("A1"), True
   .Rows(1).AutoFilter
   For Each C In Ws.Range("A2", Ws.Range("A65536").End(xlUp))
     .Columns(8).AutoFilter 8, C.Value
     Set NowWs = NowWb.Worksheets.Add
     NowWs.Name = C.Value
     .AutoFilter.Range.Copy NowWs.Range("A1")
     With NowWs
       .Rows(1).Delete
       .UsedRange.Sort Key1:=.Range("A1"), Order1:=xlAscending, Key2:=.Range("B1") _
       , Order2:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:= _
       False, Orientation:=xlTopToBottom, SortMethod:=xlPinYin, DataOption1:= _
       xlSortNormal, DataOption2:=xlSortTextAsNumbers
       .Columns("A:B").Delete
       .Cells.EntireColumn.AutoFit
     End With
     Set NowWs = Nothing
   Next C
   .AutoFilterMode = False
End With
Ws.Columns(1).Clear
Wb.Close False
With Application
   .DisplayAlerts = False
   NowWb.Sheets("Sheet1").Delete
   .DisplayAlerts = True
   .ScreenUpdating = True
End With
Set NowWb = Nothing: Set Ws = Nothing: Set Wb = Nothing
End Sub


ひとつ気になりました
発言のタグですが初心者さんは「質問」か「発言」になります
「回答」回答される方が使います。

【38750】Re:セル情報ごと 新book書き出し
発言  初心者  - 06/6/9(金) 12:00 -

引用なし
パスワード
   ▼Statis さん:
こんにちは
 毎回有難う御座います
現状 新bookが開きそこに
A1に見出し
A2から A3よりシート名となる名前が出て
Sheet1枚がでて
そこにsheet2 sheet1とあります

元データはH列オートフィルタが青
列Noが青

NowWs.Name = C.Value
NAMEメゾネットエラー状態です

すいません

【38812】Re:セル情報ごと 新book書き出し
発言  Statis  - 06/6/11(日) 8:20 -

引用なし
パスワード
   ▼初心者 さん:
こんにちは

> 毎回有難う御座います
>現状 新bookが開きそこに
>A1に見出し
>A2から A3よりシート名となる名前が出て
>Sheet1枚がでて
>そこにsheet2 sheet1とあります
>
>元データはH列オートフィルタが青
>列Noが青
>
>NowWs.Name = C.Value
>NAMEメゾネットエラー状態です

では
>NowWs.Name = C.Value
上記を削除して試してみてください。

【38846】Re:セル情報ごと 新book書き出し
発言  初心者  - 06/6/12(月) 13:43 -

引用なし
パスワード
   ▼Statis さん:
こんにちは
毎回本当にすいません
>では
>>NowWs.Name = C.Value
>上記を削除して試してみてください。

.UsedRange.Sort Key1:=.Range("A1"), Order1:=xlAscending, Key2:=.Range("B1") _
       , Order2:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:= _
       False, Orientation:=xlTopToBottom, SortMethod:=xlPinYin, DataOption1:= _
       xlSortNormal, DataOption2:=xlSortTextAsNumbers

 上記でRangeクラスSortメゾネット失敗となってしまいます

【38875】Re:セル情報ごと 新book書き出し
発言  Statis  - 06/6/13(火) 12:38 -

引用なし
パスワード
   こんにちは
う〜ん。なぜでしょうか???

オートフィルタで抽出したデータは新規シートにコピーされていますか?
確認して下さい。

【38880】Re:セル情報ごと 新book書き出し
発言  初心  - 06/6/13(火) 16:50 -

引用なし
パスワード
   ▼Statis さん:
>こんにちは
>う〜ん。なぜでしょうか???
>
>オートフィルタで抽出したデータは新規シートにコピーされていますか?
>確認して下さい。
 

.Columns(8).AutoFilter 8, C.Value
 でブレイクポイントで
Book A列に Hの各値(目次含)
とシートの中Sheet1のみが出来
そちらは何も入っていない状態です。

毎回本当に申し訳ありません

【38882】Re:セル情報ごと 新book書き出し
発言  Statis  - 06/6/13(火) 16:57 -

引用なし
パスワード
   ▼初心 さん:
>▼Statis さん:
こんにちは


>.Columns(8).AutoFilter 8, C.Value
> でブレイクポイントで
>Book A列に Hの各値(目次含)
>とシートの中Sheet1のみが出来
>そちらは何も入っていない状態です。
>
>毎回本当に申し訳ありません

オートフィルタで抽出後、抽出データはありますか?

テキストデータですがH列のデータは1行目が項目行で2行目から
データで良いですか?

【38907】Re:セル情報ごと 新book書き出し
発言  初心  - 06/6/14(水) 10:05 -

引用なし
パスワード
   ▼Statis さん:
> ▼初心 さん:
>>▼Statis さん:
>こんにちは
>
>
>>.Columns(8).AutoFilter 8, C.Value
>> でブレイクポイントで
>>Book A列に Hの各値(目次含)
>>とシートの中Sheet1のみが出来
>>そちらは何も入っていない状態です。
>>
>>毎回本当に申し訳ありません
>
>オートフィルタで抽出後、抽出データはありますか?
>
>テキストデータですがH列のデータは1行目が項目行で2行目から
>データで良いですか?

 こんにちは
有難う御座います
1行目は空セル
2行目に目次
3行目空セル
4行目よりHの項目が入っています。
よろしくお願い致します

【38922】Re:セル情報ごと 新book書き出し
回答  Statis  - 06/6/14(水) 13:30 -

引用なし
パスワード
   こんにちは


多分これで大丈夫だと思います。

Sub Test2()
Dim MyFil As String, Wb As Workbook, Ws As Worksheet
Dim NowWb As Workbook, NowWs As Worksheet, C As Range

MyFil = Application.GetOpenFilename("テキスト ファイル (*.csv), *.csv")
If MyFil = "False" Then Exit Sub
Application.ScreenUpdating = False
Set Ws = ThisWorkbook.Worksheets("Sheet1")
Set NowWb = Workbooks.Add(1)
Set Wb = Workbooks.Open(MyFil)
With Wb.ActiveSheet
   .Range("1:1,3:3").Delete Shift:=xlUp
   .Columns(8).AdvancedFilter xlFilterCopy, , Ws.Range("A1"), True
   If .AutoFilterMode = False Then
    .Rows(1).AutoFilter
   End If
   For Each C In Ws.Range("A2", Ws.Range("A65536").End(xlUp)).SpecialCells(xlCellTypeConstants)
     If Not IsEmpty(C.Value) Then
      .Columns(8).AutoFilter 8, C.Value
      If .Range("H65536").End(xlUp).Row > 1 Then
        Set NowWs = NowWb.Worksheets.Add
        NowWs.Name = C.Value
        .AutoFilter.Range.Copy NowWs.Range("A1")
        With NowWs
          .Rows(1).Delete
          .UsedRange.Sort Key1:=.Range("A1"), Order1:=xlAscending, Key2:=.Range("B1") _
          , Order2:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:=False _
          , Orientation:=xlTopToBottom, SortMethod:=xlPinYin, DataOption1:=xlSortNormal _
          , DataOption2:=xlSortTextAsNumbers
          .Columns("A:B").Delete
          .Cells.EntireColumn.AutoFit
        End With
        Set NowWs = Nothing
      End If
     End If
   Next C
   .AutoFilterMode = False
End With
Ws.Columns(1).Clear
Wb.Close False
With Application
   .DisplayAlerts = False
   NowWb.Sheets("Sheet1").Delete
   .DisplayAlerts = True
   .ScreenUpdating = True
End With
Set NowWb = Nothing: Set Ws = Nothing: Set Wb = Nothing
End Sub

【39021】Re:セル情報ごと 新book書き出し
発言  初心者  - 06/6/16(金) 9:46 -

引用なし
パスワード
   ▼Statis さん:
>こんにちは
>
>
>多分これで大丈夫だと思います。
>
>Sub Test2()
>Dim MyFil As String, Wb As Workbook, Ws As Worksheet
>Dim NowWb As Workbook, NowWs As Worksheet, C As Range
>
>MyFil = Application.GetOpenFilename("テキスト ファイル (*.csv), *.csv")
>If MyFil = "False" Then Exit Sub
>Application.ScreenUpdating = False
>Set Ws = ThisWorkbook.Worksheets("Sheet1")
>Set NowWb = Workbooks.Add(1)
>Set Wb = Workbooks.Open(MyFil)
>With Wb.ActiveSheet
>   .Range("1:1,3:3").Delete Shift:=xlUp
>   .Columns(8).AdvancedFilter xlFilterCopy, , Ws.Range("A1"), True
>   If .AutoFilterMode = False Then
>    .Rows(1).AutoFilter
>   End If
>   For Each C In Ws.Range("A2", Ws.Range("A65536").End(xlUp)).SpecialCells(xlCellTypeConstants)
>     If Not IsEmpty(C.Value) Then
>      .Columns(8).AutoFilter 8, C.Value
>      If .Range("H65536").End(xlUp).Row > 1 Then
>        Set NowWs = NowWb.Worksheets.Add
>        NowWs.Name = C.Value
>        .AutoFilter.Range.Copy NowWs.Range("A1")
>        With NowWs
>          .Rows(1).Delete
>          .UsedRange.Sort Key1:=.Range("A1"), Order1:=xlAscending, Key2:=.Range("B1") _
>          , Order2:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:=False _
>          , Orientation:=xlTopToBottom, SortMethod:=xlPinYin, DataOption1:=xlSortNormal _
>          , DataOption2:=xlSortTextAsNumbers
>          .Columns("A:B").Delete
>          .Cells.EntireColumn.AutoFit
>        End With
>        Set NowWs = Nothing
>      End If
>     End If
>   Next C
>   .AutoFilterMode = False
>End With
>Ws.Columns(1).Clear
>Wb.Close False
>With Application
>   .DisplayAlerts = False
>   NowWb.Sheets("Sheet1").Delete
>   .DisplayAlerts = True
>   .ScreenUpdating = True
>End With
>Set NowWb = Nothing: Set Ws = Nothing: Set Wb = Nothing
>End Sub

 こんにちは
毎度申し訳ありません
下記で 該当セルがありませんとなり
.Range("1:1,3:3").Delete Shift:=xlUp

Sub Test2()
Dim MyFil As String, Wb As Workbook, Ws As Worksheet
Dim NowWb As Workbook, NowWs As Worksheet, C As Range

MyFil = Application.GetOpenFilename("テキスト ファイル (*.csv), *.csv")
If MyFil = "False" Then Exit Sub
Application.ScreenUpdating = False
Set Ws = ThisWorkbook.Worksheets("Sheet1")
Set NowWb = Workbooks.Add(1)
Set Wb = Workbooks.Open(MyFil)
With Wb.ActiveSheet

   .Columns(8).AdvancedFilter xlFilterCopy, , Ws.Range("A1"), True
   If .AutoFilterMode = False Then
    .Rows(1).AutoFilter
   End If
   For Each C In Ws.Range("A2", Ws.Range("A65536").End(xlUp)).SpecialCells(xlCellTypeConstants)
     If Not IsEmpty(C.Value) Then
      .Columns(8).AutoFilter 8, C.Value
      If .Range("H65536").End(xlUp).Row > 1 Then
        Set NowWs = NowWb.Worksheets.Add
        NowWs.Name = C.Value
        .AutoFilter.Range.Copy NowWs.Range("A1")
        With NowWs
          .Rows(1).Delete
          .UsedRange.Sort Key1:=.Range("A1"), Order1:=xlAscending, Key2:=.Range("B1") _
          , Order2:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:=False _
          , Orientation:=xlTopToBottom, SortMethod:=xlPinYin, DataOption1:=xlSortNormal _
          , DataOption2:=xlSortTextAsNumbers
          .Columns("A:B").Delete
          .Cells.EntireColumn.AutoFit
        End With
        Set NowWs = Nothing
      End If
     End If
   Next C
   .AutoFilterMode = False
End With
Ws.Columns(1).Clear
Wb.Close False
With Application
   .DisplayAlerts = False
   NowWb.Sheets("Sheet1").Delete
   .DisplayAlerts = True
   .ScreenUpdating = True
End With
Set NowWb = Nothing: Set Ws = Nothing: Set Wb = Nothing
End Sub
にしたところ
Book1 A1見出し A3からH情報
sheet1枚に H情報の名前が入りましたが
情報は入りません

本当に申し訳ないです

【39030】Re:セル情報ごと 新book書き出し
回答  Statis  - 06/6/16(金) 11:19 -

引用なし
パスワード
   こんにちは
多分オートフィルタの抽出が上手く行っていないと思われます。

>.Range("1:1,3:3").Delete Shift:=xlUp
上記を下記に変更してみてください。

.Rows(1).Delete
.Rows(2).Delete

上記でCsvファイルの空白行がなくなっているはずです。

【39053】Re:セル情報ごと 新book書き出し
発言  初心者  - 06/6/16(金) 16:58 -

引用なし
パスワード
   ▼Statis さん:
>こんにちは
>多分オートフィルタの抽出が上手く行っていないと思われます。
>
>>.Range("1:1,3:3").Delete Shift:=xlUp
>上記を下記に変更してみてください。
>
>.Rows(1).Delete
>.Rows(2).Delete
>
>上記でCsvファイルの空白行がなくなっているはずです。

上記で対応しましたが駄目な状態
該当セルがないと出てしまいます
もうしわけありません

【39054】Re:セル情報ごと 新book書き出し
発言  Statis  - 06/6/16(金) 17:01 -

引用なし
パスワード
   こんにちは
そうですか??
csvファイルのレイアウトを記載して下さい。
特に1行目から5行目ぐらいまで

本日はこれで帰ります。

【39238】Re:セル情報ごと 新book書き出し
発言  初心者  - 06/6/20(火) 12:52 -

引用なし
パスワード
   ▼Statis さん:
>こんにちは
>そうですか??
>csvファイルのレイアウトを記載して下さい。
>特に1行目から5行目ぐらいまで
>
>本日はこれで帰ります。

 本当にすいません
下記に明細記載します
1行目 見出し列
2行目 より 情報が入りますが
全ての列には情報がありません
特に AB列は並順の為この前の作業マクロで作成した列で
並べる必要の無いものは空セルとなっています。
 C列も上記同様で途中行から入り始めます。
上記空セルは おおよそH列も空ですが
たまに情報が入ります。

他、全行に情報があるのはD列となり
他 情報抜けがある行が出ます。

宜しくお願い致します

【39240】Re:セル情報ごと 新book書き出し
回答  Statis  - 06/6/20(火) 13:01 -

引用なし
パスワード
   こんにちは
一度試してみてください。

Sub Test2()
Dim MyFil As String, Wb As Workbook, Ws As Worksheet
Dim NowWb As Workbook, NowWs As Worksheet, C As Range, R As Range

MyFil = Application.GetOpenFilename("テキスト ファイル (*.csv), *.csv")
If MyFil = "False" Then Exit Sub
Application.ScreenUpdating = False
Set Ws = ThisWorkbook.Worksheets("Sheet1")
Set NowWb = Workbooks.Add(1)
Set Wb = Workbooks.Open(MyFil)
With Wb.ActiveSheet
   Set R = .Range("D1", .Range("D65536").End(xlUp)).Offset(, 4)
   R.AdvancedFilter xlFilterCopy, , Ws.Range("A1"), True
   If .AutoFilterMode = False Then
    .Rows(1).AutoFilter
   End If
   For Each C In Ws.Range("A2", Ws.Range("A65536").End(xlUp)).SpecialCells(xlCellTypeConstants)
     If Not IsEmpty(C.Value) Then
      R.AutoFilter 8, C.Value
      If .Range("H65536").End(xlUp).Row > 1 Then
        Set NowWs = NowWb.Worksheets.Add
        NowWs.Name = C.Value
        .AutoFilter.Range.Copy NowWs.Range("A1")
        With NowWs
          .Rows(1).Delete
          .UsedRange.Sort Key1:=.Range("A1"), Order1:=xlAscending, Key2:=.Range("B1") _
          , Order2:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:=False _
          , Orientation:=xlTopToBottom, SortMethod:=xlPinYin, DataOption1:=xlSortNormal _
          , DataOption2:=xlSortTextAsNumbers
          .Columns("A:B").Delete
          .Cells.EntireColumn.AutoFit
        End With
        Set NowWs = Nothing
      End If
     End If
   Next C
   .AutoFilterMode = False
End With
Ws.Columns(1).Clear
Wb.Close False
With Application
   .DisplayAlerts = False
   NowWb.Sheets("Sheet1").Delete
   .DisplayAlerts = True
   .ScreenUpdating = True
End With
Set NowWb = Nothing: Set Ws = Nothing: Set Wb = Nothing
Set R = Nothing
End Sub


確認事項
1、オートフィルタは1行目の設定になっているか?
2、データは抽出されているか?
3、コピーされているか?

明日、再度見ます。

【39248】Re:セル情報ごと 新book書き出し
発言  初心者  - 06/6/20(火) 14:55 -

引用なし
パスワード
   ▼Statis さん:
>こんにちは
>一度試してみてください。
>
>Sub Test2()
>Dim MyFil As String, Wb As Workbook, Ws As Worksheet
>Dim NowWb As Workbook, NowWs As Worksheet, C As Range, R As Range
>
>MyFil = Application.GetOpenFilename("テキスト ファイル (*.csv), *.csv")
>If MyFil = "False" Then Exit Sub
>Application.ScreenUpdating = False
>Set Ws = ThisWorkbook.Worksheets("Sheet1")
>Set NowWb = Workbooks.Add(1)
>Set Wb = Workbooks.Open(MyFil)
>With Wb.ActiveSheet
>   Set R = .Range("D1", .Range("D65536").End(xlUp)).Offset(, 4)
>   R.AdvancedFilter xlFilterCopy, , Ws.Range("A1"), True
>   If .AutoFilterMode = False Then
>    .Rows(1).AutoFilter
>   End If
>   For Each C In Ws.Range("A2", Ws.Range("A65536").End(xlUp)).SpecialCells(xlCellTypeConstants)
>     If Not IsEmpty(C.Value) Then
>      R.AutoFilter 8, C.Value
>      If .Range("H65536").End(xlUp).Row > 1 Then
>        Set NowWs = NowWb.Worksheets.Add
>        NowWs.Name = C.Value
>        .AutoFilter.Range.Copy NowWs.Range("A1")
>        With NowWs
>          .Rows(1).Delete
>          .UsedRange.Sort Key1:=.Range("A1"), Order1:=xlAscending, Key2:=.Range("B1") _
>          , Order2:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:=False _
>          , Orientation:=xlTopToBottom, SortMethod:=xlPinYin, DataOption1:=xlSortNormal _
>          , DataOption2:=xlSortTextAsNumbers
>          .Columns("A:B").Delete
>          .Cells.EntireColumn.AutoFit
>        End With
>        Set NowWs = Nothing
>      End If
>     End If
>   Next C
>   .AutoFilterMode = False
>End With
>Ws.Columns(1).Clear
>Wb.Close False
>With Application
>   .DisplayAlerts = False
>   NowWb.Sheets("Sheet1").Delete
>   .DisplayAlerts = True
>   .ScreenUpdating = True
>End With
>Set NowWb = Nothing: Set Ws = Nothing: Set Wb = Nothing
>Set R = Nothing
>End Sub
>
>
>確認事項
>1、オートフィルタは1行目の設定になっているか?
>2、データは抽出されているか?
>3、コピーされているか?
>
>明日、再度見ます。


.UsedRange.Sort Key1:=.Range("A1"), Order1:=xlAscending, Key2:=.Range("B1") _
          , Order2:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:=False _
          , Orientation:=xlTopToBottom, SortMethod:=xlPinYin, DataOption1:=xlSortNormal _
          , DataOption2:=xlSortTextAsNumbers

状況をご報告します

上記にてRangeクラスsortメソッド失敗となり
下記状況です
元データ 1行目にフィルタ有
Book1 A:1にカーソル有 
1行目に目次 2行目空 3行目より抽出された値
(H列に空もあるので上記2行目が それを抽出してくれているとしたら
 こちらの勘違いで申し訳ないです)
sheet1の脇に 抽出されたH列値有

途中下記にブレークポイント作成

状況同じでsheet1とsheet2が作成されている
NowWs.Name = C.Value

毎回申し訳御座いません。

【39278】Re:セル情報ごと 新book書き出し
発言  Statis  - 06/6/21(水) 8:22 -

引用なし
パスワード
   こんにちは

>1行目に目次 2行目空 3行目より抽出された値
上記のようにコピーされている訳ですね。(すべてのデータがそうなりますか?)

記載のコードの並び替えは1行目よりデータとなりますので
いらない行を削除する事になります。

>With NowWs
>  .Rows(1).Delete
With NowWs
   .Rows("1:2").Delete

としたら如何でしょうか?

問題は、CSVファイルのデータがどのようになっているかです。
再度確認します。
CSVファイルのデータのレイアウトは同じですか?
1行目が項目行、2行目が空白、3行目からデータ

【39286】Re:セル情報ごと 新book書き出し
発言  初心者  - 06/6/21(水) 13:00 -

引用なし
パスワード
   ▼Statis さん:
>こんにちは
>
>>1行目に目次 2行目空 3行目より抽出された値
>上記のようにコピーされている訳ですね。(すべてのデータがそうなりますか?)
>
>記載のコードの並び替えは1行目よりデータとなりますので
>いらない行を削除する事になります。
>
>>With NowWs
>>  .Rows(1).Delete
>With NowWs
>   .Rows("1:2").Delete
>
>としたら如何でしょうか?
>
>問題は、CSVファイルのデータがどのようになっているかです。
>再度確認します。
>CSVファイルのデータのレイアウトは同じですか?
>1行目が項目行、2行目が空白、3行目からデータ

 すいませんでした
上記が違いあります
1行目 目次
2
3
4

4000程 でAB列に情報が入るのは100行目〜200行目以降が多いです
上記 最初に申し上げなくて 不可解の中申し訳ありませんでした

【39310】Re:セル情報ごと 新book書き出し
発言  Statis E-MAIL  - 06/6/22(木) 9:29 -

引用なし
パスワード
   こんにちは

問題なければCsvファイルをメールで見せていただく事は出来ますか?

一応、確認です。
1行目項目行・・・・必ずですか?
H列のデータの始まりはそのファイルによってちがうわけですか?
違う場合、1行目を除きH列のデータが始まる前の行まで、一時的に行を
削除して良いですか?

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