Excel VBA質問箱 IV

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

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


60770 / 76732 ←次へ | 前へ→

【20598】Re:重複データの整理について
回答  Jaka  - 04/12/13(月) 9:11 -

引用なし
パスワード
   こんにちは。
詳細はわからないけど、書いてきちゃったんで載せておきます。

Sub 勤怠3()
  Const cnsTITLE = "テキストファイル読み込み処理"
  Const cnsFILTER = "全てのファイル (*.*),*.*"
  Dim xlAPP As Application, strFILENAME As String
  Dim LsR As Long, Fdinf(1 To 4) As Variant, i As Long

  Set xlAPP = Application
  strFILENAME = xlAPP.GetOpenFilename(FileFilter:=cnsFILTER, _
    Title:=cnsTITLE)
  If StrConv(strFILENAME, vbUpperCase) = "FALSE" Then Exit Sub

  xlAPP.ScreenUpdating = False
  For i = 1 To 4
    Fdinf(i) = Array(i, 2)
  Next
  Workbooks.OpenText Filename:=strFILENAME, DataType:=xlDelimited, _
                 Comma:=True, FieldInfo:=Fdinf
  Erase Fdinf

  With ActiveSheet
    .UsedRange.Sort Key1:=.Range("C1"), Order1:=xlAscending, Key2:=.Range("D1") _
            , Order2:=xlAscending
    LsR = .Range("A65536").End(xlUp).Row
    With .Range("B1:B" & LsR)
       .Offset(, 4).Formula = "=LEFT(B1,2) & "":"" & RIGHT(B1,2)"
       .Offset(, 4).Value = .Offset(, 4).Value
       .Value = .Offset(, 4).Value
       .Offset(, 4).Clear
    End With
    .Rows(1).Insert Shift:=xlDown
    .Range("A1").Resize(, 4).Value = "WW"
    LsR = LsR + 1
    
    .Range("A1").AutoFilter Field:=3, Criteria1:="1"
    With .Range("A2:A" & LsR)
      filcct = .SpecialCells(xlCellTypeVisible).Count
      For i = 1 To 4
        Select Case i
          Case 1
           ThisWorkbook.Sheets("Sheet1").Range("A1").Resize(filcct).Value = _
                  .SpecialCells(xlCellTypeVisible).Value
          Case 2
           ThisWorkbook.Sheets("Sheet1").Range("C1").Resize(filcct).Value = _
                  .SpecialCells(xlCellTypeVisible).Offset(, i - 1).Value
          Case 4
           ThisWorkbook.Sheets("Sheet1").Range("B1").Resize(filcct).Value = _
                 .SpecialCells(xlCellTypeVisible).Offset(, i - 1).Value
        End Select
      Next
    End With
    DoEvents
    .Range("A1").AutoFilter Field:=3, Criteria1:="2"
    With .Range("A2:A" & LsR)
      filcct = .SpecialCells(xlCellTypeVisible).Count
      ThisWorkbook.Sheets("Sheet1").Range("D1").Resize(filcct).Value = _
            .SpecialCells(xlCellTypeVisible).Offset(, 1).Value
    End With
  End With
  Workbooks(Dir(strFILENAME)).Close False
  ThisWorkbook.Sheets("Sheet1").Range("C1", Range("C1").End(xlDown)).Resize(, 2).NumberFormatLocal = "hh"":""mm"
  xlAPP.ScreenUpdating = True
End Sub

0 hits

【20493】重複データの整理について m3 04/12/10(金) 13:58 質問
【20517】Re:重複データの整理について [名前なし] 04/12/10(金) 22:11 回答
【20542】Re:重複データの整理について m3 04/12/11(土) 20:36 質問
【20545】Re:重複データの整理について [名前なし] 04/12/11(土) 21:20 発言
【20548】Re:重複データの整理について m3 04/12/11(土) 22:39 質問
【20550】Re:重複データの整理について [名前なし] 04/12/11(土) 23:01 発言
【20552】Re:重複データの整理について m3 04/12/11(土) 23:08 質問
【20554】Re:重複データの整理について m3 04/12/11(土) 23:34 発言
【20555】Re:重複データの整理について [名前なし] 04/12/11(土) 23:40 回答
【20556】Re:重複データの整理について m3 04/12/12(日) 0:46 お礼
【20567】Re:重複データの整理について m3 04/12/12(日) 12:02 質問
【20569】Re:重複データの整理について [名前なし] 04/12/12(日) 12:46 回答
【20570】Re:重複データの整理について m3 04/12/12(日) 14:46 お礼
【20571】Re:重複データの整理について [名前なし] 04/12/12(日) 14:52 発言
【20584】Re:重複データの整理について m3 04/12/12(日) 22:02 質問
【20585】Re:重複データの整理について [名前なし] 04/12/12(日) 23:10 回答
【20589】Re:重複データの整理について m3 04/12/13(月) 0:23 質問
【20592】Re:重複データの整理について [名前なし] 04/12/13(月) 1:02 回答
【20593】Re:重複データの整理について m3 04/12/13(月) 1:16 お礼
【20598】Re:重複データの整理について Jaka 04/12/13(月) 9:11 回答

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