Reply
 
LinkBack Thread Tools Search this Thread Display Modes
  #1   Report Post  
Posted to microsoft.public.excel.programming
external usenet poster
 
Posts: 24
Default Merge and Move Data??

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
Search this Thread:

Advanced Search
Display Modes

Posting Rules

Smilies are On
[IMG] code is On
HTML code is Off
Trackbacks are On
Pingbacks are On
Refbacks are On


Similar Threads
Thread Thread Starter Forum Replies Last Post
How to Merge without having decimal point move? Gabby Excel Discussion (Misc queries) 1 September 7th 06 03:45 AM
mail merge excludes my headers and critical data in Word merge Nix Excel Discussion (Misc queries) 0 April 21st 06 08:35 PM
how do i get my mail merge to update the data source at each merge Steel_Monkey Excel Discussion (Misc queries) 0 November 30th 05 08:41 AM
enter data in cell which will start macro to move data to sheet2 Tommy Excel Discussion (Misc queries) 0 May 12th 05 05:00 PM
create macro to move label type data to column data JonathonWood9 Excel Programming 4 February 21st 05 10:53 PM


All times are GMT +1. The time now is 12:27 AM.

Powered by vBulletin® Copyright ©2000 - 2025, Jelsoft Enterprises Ltd.
Copyright ©2004-2025 ExcelBanter.
The comments are property of their posters.
 

About Us

"It's about Microsoft Excel"