Excel VBA質問箱 IV

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

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


42773 / 76732 ←次へ | 前へ→

【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情報の名前が入りましたが
情報は入りません

本当に申し訳ないです

4 hits

【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 発言

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