|
|
有一个分离文件，打开如图所示，想把显示框圈出来的部分删除，删除哪些代码不会影响使用？
另如果把行的值固定为2，列固定为A应该修改哪里？
Public continue As Boolean
Function GetColumn(mColumn)
Select Case mColumn
Case Is >= 53
GetColumn = "B" & Chr(mColumn + 12)
Case Is >= 26
GetColumn = "A" & Chr(mColumn + 38)
Case Else
GetColumn = Chr(mColumn + 64)
End Select
End Function
Sub Auto_Open()
'Load forms
Load Progress
Load Separate
Load Warning
'Open Warning form
' If Range("H15").Value = False Then
' continue = False
' Do
'Warning.Show
' Warning.Hide
' If continue = True Then Exit Do
' Loop
' End If
'Open form
continue = False
Do
Separate.Show
If continue = True Then Exit Do
MsgBox "Insufficient data.", 16, "Warning!"
Loop
'Change forms
Separate.Hide
Progress.Show
'Capture errors
' On Error GoTo ErrorHandler
'Turn application alerts off
Application.DisplayAlerts = False
Application.ScreenUpdating = False
'Open new workbook (if necessary)
If Separate.Email = True Then
Workbooks.Add
eFile = ActiveWorkbook.Name
Range("A1").Select
ActiveCell.FormulaR1C1 = "Date/Time Sent"
Range("B1").Select
ActiveCell.FormulaR1C1 = "Filename"
Range("C1").Select
ActiveCell.FormulaR1C1 = "E-mail Address"
Range("D1").Select
ActiveCell.FormulaR1C1 = "Subject:"
Range("D2").Select
ActiveCell.FormulaR1C1 = "Message:"
Range("A1:C1").Select
Selection.Font.Bold = True
Selection.HorizontalAlignment = xlCenter
Range("D1:D2").Select
Selection.Font.Bold = True
Selection.HorizontalAlignment = xlRight
End If
'Open filename
Workbooks.Open Separate.Filename
'Get current workbook name
MyFile = ActiveWorkbook.Name 'Left(ActiveWorkbook.Name, Len(ActiveWorkbook.Name) - 4)
'Get last row of data
Range(Separate.sort & Separate.first).Select
Selection.End(xlDown).Select
lastRow = ActiveCell.Row
'Get right most column
Range("A" & IIf(Separate.first = 1, 1, Separate.first - 1)).Select
Selection.End(xlToRight).Select
rightColumn = GetColumn(ActiveCell.Column)
'Initiate variable
tfiles = 0
'Loop through data
eRow = 2
start_row = Separate.first
For ktr = Separate.first To lastRow + 1
'Identify data
sort_data = Trim(UCase(Range(Separate.sort & start_row).Value))
'End of same data
If sort_data <> Trim(UCase(Range(Separate.sort & ktr).Value)) Then
'Copy and paste header
new_file = Trim(Left(Range(Separate.sort & start_row).Value, 26)) & ".xls"
Range("A1:" & rightColumn & IIf(Separate.first = 1, 1, Separate.first - 1)).Copy
Workbooks.Add
ActiveSheet.Paste
NewFile = ActiveWorkbook.Name
Windows(MyFile).Activate
'Copy and paste data
Range("A" & start_row, rightColumn & ktr - 1).Copy
Windows(NewFile).Activate
Range("A" & Separate.first).Select
ActiveSheet.Paste
'Bold header rows
'Rows(Separate.first).Select
Range("A1:" & rightColumn & IIf(Separate.first = 1, 1, Separate.first - 1)).Select
Selection.Font.Bold = True
'Auto fit
Cells.Select
Cells.EntireColumn.AutoFit
Cells.EntireRow.AutoFit
'Protect columns (if applicable)
If Separate.password <> "" Then
Cells.Select
Selection.Locked = False
Columns(Separate.protect_left & ":" & Separate.protect_right).Select
Selection.Locked = True
ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True, password:= _
Separate.password
ActiveSheet.EnableSelection = xlUnlockedCells
End If
'Save workbook
Range("A" & Separate.first).Select
ActiveWorkbook.SaveAs Filename:=new_file, FileFormat:= _
xlNormal, password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False
'Close workbook and return to original
ActiveWorkbook.Close
tfiles = tfiles + 1
start_row = ktr
'Paste filename in eFile
If Separate.Email = True Then
Windows(eFile).Activate
Range("B" & eRow).Select
ActiveCell.FormulaR1C1 = new_file
eRow = eRow + 1
Windows(MyFile).Activate
End If
End If
'Update status
Progress.Caption = "Progress (" & Int((ktr - Separate.first) / _
(lastRow + 1 - Separate.first) * 100 + 0.999) & "%)"
mWidth = (ktr - Separate.first) / (lastRow + 1 - Separate.first) * 192
Progress.CommandButton1.Width = IIf(mWidth > 0.1, mWidth, 0.1)
Progress.Repaint
Next ktr
'Format and close eFile
If Separate.Email = True Then
Windows(eFile).Activate
Range("A2:A" & lastRow).Select
Selection.NumberFormat = "mm/dd/yy hh:mm AM/PM"
Columns("A:B").EntireColumn.AutoFit
Columns("C:C").ColumnWidth = 30
Columns("D:D").ColumnWidth = 9
Columns("E:E").ColumnWidth = 40
Range("E2:E11").Select
Selection.MergeCells = True
Selection.WrapText = True
Selection.VerticalAlignment = xlTop
Range("Z1").Select
ActiveCell.FormulaR1C1 = "Yes"
Range("Z2").Select
ActiveCell.FormulaR1C1 = "No"
Range("D12").Select
With Selection.Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
xlBetween, Formula1:="=$Z$1:$Z$2"
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = ""
.ErrorTitle = ""
.InputMessage = "Filename within subject"
.ErrorMessage = "Yes or No"
.ShowInput = True
.ShowError = True
End With
ActiveCell.FormulaR1C1 = "No"
Selection.HorizontalAlignment = xlCenter
Range("E1").Select
Selection.HorizontalAlignment = xlLeft
Range("E12").Select
ActiveCell.FormulaR1C1 = "<---- Filename within subject"
Selection.Font.Bold = True
Range("D13").Select
ActiveCell.FormulaR1C1 = "bcc:"
Selection.Font.Bold = True
Selection.HorizontalAlignment = xlRight
'Start VEN 06-NOV-09
Range("D14").Select
ActiveCell.FormulaR1C1 = "Cc:"
Selection.Font.Bold = True
Selection.HorizontalAlignment = xlRight
'End Ven 06-NOV-09
Range("A2").Select
ActiveWorkbook.SaveAs Filename:="File list for e-mailing.xls"
ActiveWorkbook.Close
End If
'Flash message
MsgBox "Files separated: " & tfiles & IIf(Separate.Email = True, _
Chr(13) & Chr(13) & "E-mail list saved!", ""), vbExclamation, "Macro Complete!"
'Close macro
ActiveWorkbook.Close
Unload Progress
Range("H15").Select
ActiveCell.FormulaR1C1 = Warning.showWarning
ActiveWorkbook.Save
ActiveWorkbook.Close
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Exit Sub
ErrorHandler:
'Activate original spreadsheet
Windows(MyFile).Activate
'Splash warning
bCell = UCase(Separate.sort) & start_row
cCell = UCase(Separate.sort) & ktr - 1
IRange = IIf(bCell = cCell, bCell, bCell & ":" & cCell)
Unload Separate
If Err.Number = 1004 Then
MsgBox "The file will not save because there is" & _
Chr(13) & "an illegal character in " & IIf(Len(IRange) _
<= 4, "cell " & IRange, "the range " & IRange) & "." & _
Chr(13) & "Please correct the problem before" & _
Chr(13) & "proceeding.", vbCritical, "WARNING!"
Else
Dim Msg
Msg = "Error # " & Str(Err.Number) & " was generated by " _
& Err.Source & Chr(13) & Err.Description
MsgBox Msg, , "Error", Err.HelpFile, Err.HelpContext
End If
'Close macro
Unload Progress
ActiveWorkbook.Close
ActiveWorkbook.Close
Range("H15").Select
ActiveCell.FormulaR1C1 = Warning.showWarning
ActiveWorkbook.Save
ActiveWorkbook.Close
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub |
-
|
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2023-3-15 14:58
楼主