HiI have 2 problems with an excel macro that I inherited many years ago and it seems a little too complex for my limited knowledge of macros.The first problem is that the macro takes a spreadsheet that has been sorted by column A (in this instance that is Supplier Names)and splits the files at each new supplier name and saves. This gives me circa 60 new individual files. This works perfectly and is easy to use. However, this macro is used at least once per week and the output files all need to be saved. Since the new file names are basically just a reflection of column A data, I manually need to rename the previous weeks files before I can run this. I am looking for a way to differentiate the current weeks files from the previous weeks using the macro. The easist way I can think is to have the date added to the end of the supplier name each week but I can't find a way to add this into the macro. The second problem is that there is an additional file that is supposed to record all the file names to allow the files to be sent via email but the instructions are not clear on how to set this up, where to record the email addresses etc. Any insight in to either of these problems would be very much appreciated.Below is the macro details:Dim efile As StringPublic continue As BooleanFunction 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 FunctionSub Auto_Open() 'Load forms Load Progress Load Separate Load Warning 'Open Warning form If Range("H15").Value = False Then continue = False Do Warning.Show 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 = "
↧