Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
d = Format(Now(), "yyyy-mm-dd_HH.mm.ss")
s = Left(ThisWorkbook.Name, InStrRev(ThisWorkbook.Name, ".") - 1)
ThisWorkbook.SaveCopyAs "E:\test\" & s & "_" & d & ".xlsm"End Sub
转载于:https://www.cnblogs.com/doctorsun/p/7684363.html
Sub changeFile() '出错时直接跳到完成 On Error GoTo 100 Dim file As String Dim basePath As String Dim val basePath = InputBox("请输入路径") If basePath = "" Then MsgBox "请输入路径" Exit Sub End If val = InputBox("请输入你要修改成的值") '忽略修改警告 Application.DisplayAlerts = False '查找某路径下面所有的txt文档并弹出文件名 file = Dir("C:\Users\星驰太帅了\Desktop\excel\*.xlsx") a = SetValue(basePath, file, val) Debug.Print "根文件下面的文件 " & file '如果文件名不为空代表还有文件,那么就一直循环 Do While file <> "" '第二次不需要再填写路径,要不然会造成死循环 file = Dir '再判断一下,免得当为空时还做了操作 If file = "" Then Exit Do a = SetValue(basePath, file, val) Debug.Print "根文件下面的文件 " & file Loop '结束语提示 Debug.Print "end" '重新开启警告 Application.DisplayAlerts = True 100: MsgBox "修改完成" End Sub Function SetValue(basePath, worksPath, value) Dim rowCount Dim c As Range filePath = basePath & worksPath With Workbooks.Open(filePath) '第一列最后一行 rowCount = .Sheets(1).Cells(Rows.Count, 1).End(xlUp).row For Each c In Range("a1:a" & rowCount) If c.value = "编制日期：" Then .Sheets(1).Cells(c.row, 2).value = value Exit For End If Next .Save '修改完需要保存文件 .Close End With End Function
可以用find 函数更容易,如下
Function SetValue(basePath, worksPath, value) Dim c As Range Dim rowCount As Range filePath = basePath & worksPath With Workbooks.Open(filePath) '第一列最后一行 Set rowCount = .Sheets(1).Cells.Find("编制日期：", , xlFormulas, , , xlPrevious) .Sheets(1).Cells(rowCount.row, 2).value = value .Save '修改完需要保存文件 .Close End With End Function
Sub chooseDocumentPath() 'Auther 云浮清秋 '弹框选择文件路径 '---------------------------------------------- Dim dataExcel, Workbook, dataSheet, filePath Dim totalRow As Integer Set dataExcel = CreateObject("Excel.Application") filePath = Application.GetOpenFilename(Title:="弹框显示的标题文本内容", MultiSelect:=False) '可以选择各种格式的文件 ' filePath = Application.GetOpenFilename("Excel Files (*.xls*), *.Excel") '必须选择excel格式的文件 If filePath <> False Then Set Workbook = dataExcel.Workbooks.Open(filePath) Set dataSheet = Workbook.Worksheets(1) On Error GoTo noData totalRow = dataSheet.UsedRange.Find(what:="*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row For i = 2 To totalRow Sheets("sheet1").Cells(i, 1) = dataSheet.Cells(i, 1) Sheets("sheet1").Ce
使用说明
本人为初学者（写的不好轻喷），根据大神的写法弄的精简版，中间出现空格可正常统计。
未进行序号填充
点击取消会报错
其他BUG后续将会继续完善
Sub 表格关键词拆分() Application.ScreenUpdating = False Dim x As Integer, y As Integer, w As Worksheet inputcol = InputBox("请输入拆分列所在序号") x = 2 y = inputcol Set w = Worksheets(1) Do While w.Cells(x, y).Value <> "" On Error Resume Next If Worksheets(w.Cells(x, y).Value) Is Nothing Then Worksheets.Add after:=Worksheets(Worksheets.Count) ActiveSheet.Name = w.Cells(x, y).Value w.Cells(1, 1).Resize(1, 100).Copy Worksheets(w.Cells(x, y).Value).Cells(1, 1) End If w.Cells(x, 1).Resize(1, 100).Copy Worksheets(w.Cells(x, y).Value).Range("A60000").End(xlUp).Offset(1, 0) x = x + 1 Loop Dim folder As String folder = ThisWorkbook.Path & "拆分工作表" If Len(Dir(folder, vbDirectory)) = 0 Then MkDir folder Dim i As Integer, sht As Worksheet For i = 2 To Sheets.Count Sheets(i).Copy ActiveWorkbook.SaveAs folder & "\" & Sheets(1).Name & ".xls" ActiveWorkbook.Close Next End Sub
