Home |
Search |
Today's Posts |
|
#1
![]()
Posted to microsoft.public.excel.programming
|
|||
|
|||
![]()
I have a program that grabs data from a particular folder and merges the
data.. Adds formulas, columns, etc.. However, I want to move the orginal workbooks to a different folder. So, the user will be able to put active workbooks to merge and after the program runs its empty again ready for the user to put additional workbooks. Please let me know if this is possible. The code is below.. thanks in advance for the help.... Private Sub Workbook_Open() Dim Path As String Dim FileName As String Dim Wkb As Workbook Dim WS As Worksheet Dim bdFileName As String Dim FullFileName As String Application.DisplayAlerts = False FullFileName = ActiveWorkbook.FullName bdFileName = Left(ActiveWorkbook.Name, _ Len(ActiveWorkbook.Name) - 4) ActiveWorkbook.SaveCopyAs FileName:="H:\My Documents\COMPLETED_FILES_CMS\BACK_UP\" & _ "BACK_UP_" & bdFileName & Format(Now, "_YYYY_MM-DD_H-MM-SS") & _ ".xls" Application.DisplayAlerts = False Sheets.Add Sheets("UPLOAD_FILE").Delete Application.EnableEvents = True Application.ScreenUpdating = True Path = "H:\My Documents\COMPLETED_FILES_CMS" FileName = Dir(Path & "\*.xls", vbNormal) Do Until FileName = "" Set Wkb = Workbooks.Open(FileName:=Path & "\" & FileName, Password:="resolution") For Each WS In Wkb.Worksheets WS.Unprotect WS.Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Cou nt) Next WS Wkb.Close False FileName = Dir() Loop Application.EnableEvents = True Application.ScreenUpdating = True Dim sh As Worksheet Dim DestSh As Worksheet Dim Last As Long On Error Resume Next If Len(ThisWorkbook.Worksheets.Item("UPLOAD_FILE").Na me) = 0 Then On Error GoTo 0 Application.ScreenUpdating = False Set DestSh = ThisWorkbook.Worksheets.Add DestSh.Name = "UPLOAD_FILE" For Each sh In ThisWorkbook.Worksheets If Left(sh.Name, 3) < "She" Then Last = LastRow(DestSh) sh.Rows("1:350").Copy DestSh.Cells(Last + 1, "A") End If Next DestSh.Cells.Sort Key1:=DestSh.Range("b2"), Order1:=xlAscending, Header:=xlYes, _ Key2:=DestSh.Range("c2"), Order2:=xlAscending, Header:=xlYes, _ OrderCustom:=1, MatchCase:=False, _ Orientation:=xlTopToBottom 'DestSh.Cells(1).Select Application.ScreenUpdating = True Else MsgBox "The sheet Master already exist" End If Application.EnableEvents = True Application.ScreenUpdating = True For Each sh In ThisWorkbook.Worksheets If Left(sh.Name, 3) = "She" Then sh.Delete End If Next sh 'Sheets("UPLOAD_FILE").Range("A1:AA35000").Copy 'Sheets("FILE SENT FROM CMS").Range("A982:AA35982").PasteSpecial For Each sh In ThisWorkbook.Worksheets If Left(sh.Name, 2) < "UP" Then sh.Delete End If Next sh Sheets("UPLOAD_FILE").Columns("J:J").Insert Sheets("UPLOAD_FILE").Columns("J:J").Insert Sheets("UPLOAD_FILE").Columns("J:J").Insert Sheets("UPLOAD_FILE").Range("J1").FormulaR1C1 = "FIRST NAME" Sheets("UPLOAD_FILE").Range("K1").FormulaR1C1 = "LAST NAME" Sheets("UPLOAD_FILE").Range("L1").FormulaR1C1 = "COMMENTS/MIDDLE INITIAL" Sheets("UPLOAD_FILE").Range("AD1").FormulaR1C1 = "DEPT" Sheets("UPLOAD_FILE").Range("AE1").FormulaR1C1 = "SOURCE" Sheets("UPLOAD_FILE").Range("AF1").FormulaR1C1 = "LIS ELIGIBILITY LEVEL" Sheets("UPLOAD_FILE").Range("AG1").FormulaR1C1 = "DATE RECEIVED" Sheets("UPLOAD_FILE").Range("AH1").FormulaR1C1 = "RESOLUTION" Sheets("UPLOAD_FILE").Range("AI1").FormulaR1C1 = "RESOLUTION DATE" Sheets("UPLOAD_FILE").Range("AJ1").FormulaR1C1 = "AGING" Dim iLastRow As Long Dim sFormula As String sFormula = "=LEFT(I2,IF(ISERROR(FIND("" "",I2,1)),LEN(I2),FIND("" "",I2,1)-1))" iLastRow = Cells(Rows.Count, "I").End(xlUp).Row With Range("J2") ..Formula = sFormula ..AutoFill .Resize(iLastRow - 5) End With sFormula = "=TRIM(IF(ISERROR(FIND("" "",I2,1)),I2,MID(I2,FIND("" "",I2,1)+1,IF(ISERROR(FIND("" "",I2,FIND("" "",I2,1)+2)),LEN(I2),FIND("" "",I2,FIND("" "",I2,1)+2))-FIND("" "",I2,1))))" iLastRow = Cells(Rows.Count, "I").End(xlUp).Row With Range("k2") ..Formula = sFormula ..AutoFill .Resize(iLastRow - 5) End With sFormula = "=TRIM(RIGHT(I2,LEN(I2)-IF(ISERROR(FIND("" "",I2,FIND("" "",I2,FIND("" "",I2,1)+2))),LEN(I2),FIND("" "",I2,FIND("" "",I2,FIND("" "",I2,1)+2))-1)))" iLastRow = Cells(Rows.Count, "I").End(xlUp).Row With Range("L2") ..Formula = sFormula ..AutoFill .Resize(iLastRow - 5) End With sFormula = "=TODAY()" iLastRow = Cells(Rows.Count, "I").End(xlUp).Row With Range("AG2") ..Formula = sFormula ..AutoFill .Resize(iLastRow - 5) End With ActiveWorkbook.SaveCopyAs FileName:="H:\My Documents\COMPLETED_FILES_CMS\FINAL_REPORT\" & _ bdFileName & Format(Now() - 1, "_YYYY_MM-DD") & _ ".xls" Application.DisplayAlerts = False Workbooks.Close End Sub |
Reply |
Thread Tools | Search this Thread |
Display Modes | |
|
|
![]() |
||||
Thread | Forum | |||
How to Merge without having decimal point move? | Excel Discussion (Misc queries) | |||
mail merge excludes my headers and critical data in Word merge | Excel Discussion (Misc queries) | |||
how do i get my mail merge to update the data source at each merge | Excel Discussion (Misc queries) | |||
enter data in cell which will start macro to move data to sheet2 | Excel Discussion (Misc queries) | |||
create macro to move label type data to column data | Excel Programming |