宏中另存为的时的文件名问题？

lihaosqy

大家好，由于我有多个excel需要进行操作，所以希望每次运行宏的时候在最后阶段的另存为文件名按源文件名命名，请问该如何实现？
即下列宏中得    dist_aga_0.02-2_46b_1.xvg 在运行在不同的文件时名称是它自己的名字

    "D:\paper\data\distance\lz\flat50q0.02pro++--0.02pme\2\xlx\dist_aga_0.02-2_46b_1.xvg" _
        , FileFormat:=xlExcel8, Password:="", WriteResPassword:="", _
        ReadOnlyRecommended:=False, CreateBackup:=False
    ActiveWorkbook.Close
End Sub


谢谢大家

wisdom100

不知道你是否是 获取文件名吗？  说的复杂了

1. Sub GetFileName(ByVal fname As String)
   
2. 
   
3.     Dim fs, fold, fls, fl
   
4.     Dim lr, val As Integer
   
5.     val = 0
   
6.     Range("b6:d30").ClearContents '表格清空
   
7.    
   
8.     Set fs = CreateObject("Scripting.FileSystemObject")
   
9.     Set fold = fs.getfolder(fname) 'folderpath指文件夹路径，string型，实践中自行替换
   
10.     Set fls = fold.Files
    
11.    
    
12.     For Each fl In fls
    
13.         If InStr(fl.Name, ".xls") <> 0 Or InStr(fl.Name, ".xlsx") <> 0 Then '避免打开非Excel文件
    
14.             'Workbooks.Open fl.Path  '打开文件
    
15.            ' statements '处理代码
    
16.            ' Workbooks(fl.Name).Close Savechanges:=True  '关闭文件
    
17.             lr = Range("c100").End(xlUp).Row
    
18.             Cells(lr + 1, 3).Value = JieQu(fl.Name)
    
19.             Cells(lr + 1, 2).Value = val + 1
    
20.             val = Cells(lr + 1, 2).Value
    
21.         End If
    
22. 
    
23.     Next
    
24.    
    
25.    
    
26. End Sub

复制代码

wisdom100

遗漏了一个自定义函数

1. '截取----
   
2. Public Function JieQu(ByVal fname As String) As String
   
3.     Dim ss
   
4.     ss = Split(fname, "")
   
5.     JieQu = ss(UBound(ss))
   
6. End Function

复制代码

lihaosqy

wisdom100 发表于 2012-4-28 09:29
不知道你是否是 获取文件名吗？  说的复杂了

感谢回复！
应该是没有获取文件名，请问这些代码是加在哪里？用thisworkbook.name可以么？怎么加？

jlhao

lihaosqy 发表于 2012-4-28 09:34
感谢回复！
应该是没有获取文件名，请问这些代码是加在哪里？用thisworkbook.name可以么？怎么加？

可以用下面两行来取当前文件名和路径，你的代码不全，应该在存文件前把文件名变量赋值

1. ThisWorkbook.Path
   
2. ThisWorkbook.Name

复制代码

lihaosqy

jlhao 发表于 2012-4-28 09:57
可以用下面两行来取当前文件名和路径，你的代码不全，应该在存文件前把文件名变量赋值

Sub 分列()
'
' 分列 宏
'
' 快捷键: Ctrl+d
'
    ActiveWindow.SmallScroll Down:=-9
    Range("A23").Select
    ActiveWindow.ScrollRow = 342
    ActiveWindow.ScrollRow = 527
    ActiveWindow.ScrollRow = 852
    ActiveWindow.ScrollRow = 1085
    ActiveWindow.ScrollRow = 1967
    ActiveWindow.ScrollRow = 2741
    ActiveWindow.ScrollRow = 3205
    ActiveWindow.ScrollRow = 3964
    ActiveWindow.ScrollRow = 4413
    ActiveWindow.ScrollRow = 4970
    ActiveWindow.ScrollRow = 5264
    ActiveWindow.ScrollRow = 5837
    ActiveWindow.ScrollRow = 6100
    ActiveWindow.ScrollRow = 6333
    ActiveWindow.ScrollRow = 6611
    ActiveWindow.ScrollRow = 7076
    ActiveWindow.ScrollRow = 7230
    ActiveWindow.ScrollRow = 7463
    ActiveWindow.ScrollRow = 7587
    ActiveWindow.ScrollRow = 7803
    ActiveWindow.ScrollRow = 7927
    ActiveWindow.ScrollRow = 8144
    ActiveWindow.ScrollRow = 8314
    ActiveWindow.ScrollRow = 8531
    ActiveWindow.ScrollRow = 8686
    ActiveWindow.ScrollRow = 8887
    ActiveWindow.ScrollRow = 9026
    ActiveWindow.ScrollRow = 9196
    ActiveWindow.ScrollRow = 9413
    ActiveWindow.ScrollRow = 9522
    ActiveWindow.ScrollRow = 9599
    ActiveWindow.ScrollRow = 9676
    ActiveWindow.ScrollRow = 9738
    ActiveWindow.ScrollRow = 9800
    ActiveWindow.ScrollRow = 9816
    ActiveWindow.ScrollRow = 9862
    ActiveWindow.ScrollRow = 9878
    ActiveWindow.ScrollRow = 9893
    ActiveWindow.ScrollRow = 9924
    ActiveWindow.ScrollRow = 9940
    ActiveWindow.ScrollRow = 9971
    ActiveWindow.ScrollRow = 9986
    ActiveWindow.SmallScroll Down:=6
    Range("A23:A10023").Select
    Selection.TextToColumns Destination:=Range("A23"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=True, _
        Semicolon:=False, Comma:=False, Space:=True, Other:=False, FieldInfo _
        :=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1), Array(6, 1)), _
        TrailingMinusNumbers:=True
    ChDir "D:\paper\data\distance\lz\flat50q0.02pro++--0.02pme\2\xlx"
    ActiveWorkbook.SaveAs Filename:= _
        "D:\paper\data\distance\lz\flat50q0.02pro++--0.02pme\2\xlx\" & ThisWorkbook.Name &".xvg" _
        , FileFormat:=xlExcel8, Password:="", WriteResPassword:="", _
        ReadOnlyRecommended:=False, CreateBackup:=False
End Sub

jlhao

lihaosqy 发表于 2012-4-28 10:07
Sub 分列()
'
' 分列 宏

你代码里的有效部分为：

1. Sub 分列()
   
2. '
   
3. ' 分列 宏
   
4. '
   
5. ' 快捷键: Ctrl+d
   
6. '
   
7.     Range("A23:A10023").Select
   
8.     Selection.TextToColumns Destination:=Range("A23"), DataType:=xlDelimited, _
   
9.         TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=True, _
   
10.         Semicolon:=False, Comma:=False, Space:=True, Other:=False, FieldInfo _
    
11.         :=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1), Array(6, 1)), _
    
12.         TrailingMinusNumbers:=True
    
13.     ChDir "D:\paper\data\distance\lz\flat50q0.02pro++--0.02pme\2\xlx"
    
14.     ActiveWorkbook.SaveAs Filename:= _
    
15.         "D:\paper\data\distance\lz\flat50q0.02pro++--0.02pme\2\xlx" & ThisWorkbook.Name & ".xvg" _
    
16.         , FileFormat:=xlExcel8, Password:="", WriteResPassword:="", _
    
17.         ReadOnlyRecommended:=False, CreateBackup:=False
    
18. End Sub
    

复制代码

lihaosqy

jlhao 发表于 2012-4-28 10:19
你代码里的有效部分为：

恩，大侠请问这个宏在其它excel运行的时候依然不可以读取且保存当前文件名，怎么解决？
（如果宏是存在个人宏文件夹，则生成文件名为PERSONAL.XLSB.xvg，如果保存在当前文件里，生成的文件名也不对）

jlhao

lihaosqy 发表于 2012-4-28 10:27
恩，大侠请问这个宏在其它excel运行的时候依然不可以读取且保存当前文件名，怎么解决？
（如果宏是存在个 ...

你用

1. msgbox ThisWorkbook.Name

复制代码

看一下显示的文件名是什么？

lihaosqy

jlhao 发表于 2012-4-28 10:31
你用看一下显示的文件名是什么？

请问在哪里输入这个？
下面是例子
dist_aga_0.02-2_46b_1.rar (204.6 KB, 下载次数: 8)

2012-4-28 10:49 上传

点击文件名下载附件

dist_aga_0.02-2_46b_2.rar (200.44 KB, 下载次数: 6)

2012-4-28 10:50 上传

点击文件名下载附件