LinkBack Thread Tools Search this Thread Display Modes
Prev Previous Post   Next Post Next
  #1   Report Post  
Posted to microsoft.public.excel.programming
external usenet poster
 
Posts: 24
Default Merge and move worksheets

Is there a way to merge multiple worksheets and after the data is merged.
each merged workbook is moved to a folder name complete. The code I'm using
is below. I have the merge part down, just need help with the move... Thanks
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



 
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 can I merge two worksheets together foxefire21 Excel Worksheet Functions 2 October 27th 07 01:05 AM
How to Merge without having decimal point move? Gabby Excel Discussion (Misc queries) 1 September 7th 06 03:45 AM
Merge and Move Data?? THE_RAMONES Excel Programming 0 February 17th 06 04:30 PM
Worksheets won't merge! Frustrated!!!! Excel Worksheet Functions 1 September 20th 05 03:09 AM
Merge Worksheets Mark Jackson Excel Worksheet Functions 0 June 8th 05 10:42 PM


All times are GMT +1. The time now is 05:11 PM.

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"