ªð¦^¦Cªí ¤W¤@¥DÃD µo©«

[µo°Ý] ¦p¦ó¶×¤J¦h­Ó¸ê®Æ§¨¤å¦rÀɤº®e

[µo°Ý] ¦p¦ó¶×¤J¦h­Ó¸ê®Æ§¨¤å¦rÀɤº®e

¤p§Ì³Ìªñ­è¾ÇVBA,
§Ú·Q±q«ü©w¥Ø¿ýD:\TEST, «ö¤U" ¶×¤J"«ö¶s,
¦Û°Ê¨ú¥X¸ê®Æ§¨¸Ìªº¤å¦rÀÉ(*.ccc)²Ä¤@¦C¤º®e, ½Æ»s©ñ¤Jtest.xls¤¤ªºSheets("IN"), ¥ÑG2¶}©l¨Ì¦¸¶×¤J¸ê®Æ.

¥H¤U¬O§Ú¥Î¥¨¶°¿ý»s¤è¦¡¥u¿ý4­Ó¸ê®Æ§¨  
³Â·Ð½Ð±Ð¥ý¶i!!

Sub Macro1()
'
' Macro1 Macro
'
' §Ö³tÁä: Ctrl+k
'
    Sheets("Sheet1").Select
    Range("A1").Select
    With ActiveSheet.QueryTables.Add(Connection:= _
        "TEXT;D:\TEST\TT_00011111\00011112.ccc", Destination:=Range("$A$1"))
        .Name = "00011112"
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .TextFilePromptOnRefresh = False
        .TextFilePlatform = 1252
        .TextFileStartRow = 1
        .TextFileParseType = xlFixedWidth
        .TextFileTextQualifier = xlTextQualifierDoubleQuote
        .TextFileConsecutiveDelimiter = False
        .TextFileTabDelimiter = True
        .TextFileSemicolonDelimiter = False
        .TextFileCommaDelimiter = False
        .TextFileSpaceDelimiter = False
        .TextFileColumnDataTypes = Array(9, 2)
        .TextFileFixedColumnWidths = Array(1)
        .TextFileTrailingMinusNumbers = True
        .Refresh BackgroundQuery:=False
    End With
    Selection.Copy
    Sheets("IN").Select
    Range("G2").Select
    ActiveSheet.Paste
    Sheets("Sheet1").Select
    Application.CutCopyMode = False
    Selection.Delete Shift:=xlUp
    Range("A1").Select
    With ActiveSheet.QueryTables.Add(Connection:= _
        "TEXT;D:\TEST\TT_00012345\12345678.ccc", Destination:=Range("$A$1"))
        .Name = "12345678"
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .TextFilePromptOnRefresh = False
        .TextFilePlatform = 1252
        .TextFileStartRow = 1
        .TextFileParseType = xlFixedWidth
        .TextFileTextQualifier = xlTextQualifierDoubleQuote
        .TextFileConsecutiveDelimiter = False
        .TextFileTabDelimiter = True
        .TextFileSemicolonDelimiter = False
        .TextFileCommaDelimiter = False
        .TextFileSpaceDelimiter = False
        .TextFileColumnDataTypes = Array(9, 2)
        .TextFileFixedColumnWidths = Array(1)
        .TextFileTrailingMinusNumbers = True
        .Refresh BackgroundQuery:=False
    End With
    Selection.Copy
    Sheets("IN").Select
    Range("G3").Select
    ActiveSheet.Paste
    Sheets("Sheet1").Select
    Application.CutCopyMode = False
    Selection.Delete Shift:=xlUp
    Range("A1").Select
    With ActiveSheet.QueryTables.Add(Connection:= _
        "TEXT;D:\TEST\TT_00022222\00333333.ccc", Destination:=Range("$A$1"))
        .Name = "00333333"
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .TextFilePromptOnRefresh = False
        .TextFilePlatform = 1252
        .TextFileStartRow = 1
        .TextFileParseType = xlFixedWidth
        .TextFileTextQualifier = xlTextQualifierDoubleQuote
        .TextFileConsecutiveDelimiter = False
        .TextFileTabDelimiter = True
        .TextFileSemicolonDelimiter = False
        .TextFileCommaDelimiter = False
        .TextFileSpaceDelimiter = False
        .TextFileColumnDataTypes = Array(9, 2)
        .TextFileFixedColumnWidths = Array(1)
        .TextFileTrailingMinusNumbers = True
        .Refresh BackgroundQuery:=False
    End With
    Selection.Copy
    Sheets("IN").Select
    Range("G4").Select
    ActiveSheet.Paste
    Sheets("Sheet1").Select
    Application.CutCopyMode = False
    Selection.Delete Shift:=xlUp
    Range("A1").Select
    With ActiveSheet.QueryTables.Add(Connection:= _
        "TEXT;D:\TEST\TT_00023456\25153654.ccc", Destination:=Range("$A$1"))
        .Name = "25153654"
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .TextFilePromptOnRefresh = False
        .TextFilePlatform = 1252
        .TextFileStartRow = 1
        .TextFileParseType = xlFixedWidth
        .TextFileTextQualifier = xlTextQualifierDoubleQuote
        .TextFileConsecutiveDelimiter = False
        .TextFileTabDelimiter = True
        .TextFileSemicolonDelimiter = False
        .TextFileCommaDelimiter = False
        .TextFileSpaceDelimiter = False
        .TextFileColumnDataTypes = Array(9, 2)
        .TextFileFixedColumnWidths = Array(1)
        .TextFileTrailingMinusNumbers = True
        .Refresh BackgroundQuery:=False
    End With
    Selection.Copy
    Sheets("IN").Select
    Range("G5").Select
    ActiveSheet.Paste
    Sheets("Sheet1").Select
    Application.CutCopyMode = False
    Selection.Delete Shift:=xlUp
    Range("A1").Select
    Cells.Select
    Selection.QueryTable.Delete
    Selection.QueryTable.Delete
    Selection.QueryTable.Delete
    Selection.QueryTable.Delete
    Selection.ClearContents
    Sheets("IN").Select
    Range("A1").Select
End Sub

TEST.rar (26.44 KB)

TEST.rar (26.04 KB)

¦^´_ 1# luke
  1. Sub ¶×¤J()
  2. Dim ary() As String, rw As Long, Mystr$, MyPath$
  3. rw = 2: i = 0
  4. path1 = "D:\TEST\"
  5. file1 = Dir(path1 & "*.*", vbDirectory) '¥u³B²z¸ê®Æ§¨
  6. Do While file1 <> ""
  7.   If file1 <> "." And file1 <> ".." And _
  8.      GetAttr(path1 & file1) = vbDirectory Then
  9.      i = i + 1
  10.      ReDim Preserve ary(i)
  11.      ary(i) = file1
  12.   End If
  13.   file1 = Dir
  14. Loop
  15. For i = 1 To UBound(ary)
  16.    Cells(rw, 1) = ary(i)
  17.    MyPath = path1 & ary(i) & "\"
  18.    fs = Dir(MyPath & "*.ccc")
  19.    Open MyPath & fs For Input As #1
  20.    Line Input #1, Mystr
  21.    Cells(rw, 7) = Mid(Mystr, 2)
  22.    Close #1
  23.    rw = rw + 1
  24. Next i
  25. End Sub
½Æ»s¥N½X
¾Ç®üµL²P_¤£®¢¤U°Ý

TOP

        ÀR«ä¦Û¦b : ¤£­n¤p¬Ý¦Û¤v¡A¦]¬°¤H¦³µL­­ªº¥i¯à¡C
ªð¦^¦Cªí ¤W¤@¥DÃD