[已解决]读取数据后另存

liz917

Option Explicit
Sub 按钮1_Click()
    Dim str1$, str2$, oldname$, newname$, i%, r%, k%, arr
    Dim fso As Object, f As Object, ff As Object, f1 As Object
    str2 = ActiveWorkbook.Path
    Set fso = CreateObject("scripting.filesystemobject")
    Set f = fso.GetFolder(str2 & "\data\")
    Set ff = f.Files
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    i = 1
    For Each f1 In ff
        oldname = f1.Name
        newname = Replace(oldname, ".csv", ".xls")
        Workbooks.Add
        k = FreeFile
        Open f1 For Input As #k
        r = 1
        Do
            Line Input #k, str1
            arr = Split(str1, ",")
            ActiveSheet.Cells(r, 1).Resize(1, UBound(arr) + 1) = arr
            r = r + 1
        Loop Until EOF(k)
        ActiveWorkbook.SaveAs Filename:=str2 & "\over\" & newname
        ActiveWorkbook.Close
    Next
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    Set fso = Nothing: Set f = Nothing: Set ff = Nothing: Set f1 = Nothing
End Sub

平地三尺浪

原来用VBA啊，不太会

hxgfkfb

学习         

wayy

楼主哪去了？２楼的代码应该可以的。

liz917

回复 a409902202 的帖子


Sub 按钮1_Click()
    Dim str1$, str2$, oldname$, newname$, i%, r%, k%, arr
    Dim fso As Object, f As Object, ff As Object, f1 As Object
    str2 = ActiveWorkbook.Path
    Set fso = CreateObject("scripting.filesystemobject")
    Set f = fso.GetFolder(str2 & "\data\")
    Set ff = f.Files
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    ActiveSheet.Cells.Clear '新加
    i = 1
    For Each f1 In ff
        oldname = f1.Name
        newname = Replace(oldname, ".csv", ".xlsm") '改
       ' Workbooks.Add
        k = FreeFile
        Open f1 For Input As #k
        r = 1
        Do
            Line Input #k, str1
            arr = Split(str1, ",")
            ActiveSheet.Cells(r, 1).Resize(1, UBound(arr) + 1) = arr
            r = r + 1
        Loop Until EOF(k)
        ActiveWorkbook.SaveAs Filename:=str2 & "\over\" & newname
      '  ActiveWorkbook.Close
    Next
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    Set fso = Nothing: Set f = Nothing: Set ff = Nothing: Set f1 = Nothing
End Sub

Thenea

楼上的太厉害了，好好学习~~