halimi1306
04-15-2011, 09:43 PM
Hi Pals,
How to combine moduls into single module? Below are my code for your reference.
Code 1:
Option Explicit
Public Sub ImportSheetData()
Dim sFld As String, sFlPath As String, sFile As String
Dim vPath As Variant
Dim wb As Workbook, wbThisBk As Workbook
Dim ws As Worksheet
Dim i As Integer
Application.DisplayAlerts = False
Application.ScreenUpdating = False
'For calling the deletion sub
Call DeleteOldSheets
Set wbThisBk = ThisWorkbook
'Getting the path
sFlPath = Application.GetOpenFilename("Excel Files (*.xls*), *.xls*")
If sFlPath = "False" Then
MsgBox "No Files Selected"
Exit Sub
Else
vPath = Split(sFlPath, "\")
sFld = ""
For i = LBound(vPath) To UBound(vPath)
If InStr(1, vPath(i), ".xls") = 0 Then
sFld = sFld & vPath(i) & "\"
End If
Next i
ChDir sFld
sFile = Dir("*.xls*")
Do While sFile <> ""
Set wb = Workbooks.Open(sFld & sFile)
For Each ws In wb.Sheets
ws.Copy Before:=wbThisBk.Sheets("End")
Next ws
wb.Close False
sFile = Dir
Loop
End If
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Private Sub DeleteOldSheets()
'Deleting old worksheets except Model Engine, Guidelines, Macro Control, Summary Dashboard and End
Dim ws As Worksheet
For Each ws In ThisWorkbook.Sheets
Select Case ws.Name
Case "Model Engine (Read Only)", "Guidelines (Read Only)", "Macro Control (Read Only)", "Summary Dashboard", "End"
'do nothing
Case Else
ws.Delete
End Select
Next ws
End Sub
Code 2:
Sub SortWorksheets()
Dim N As Integer
Dim M As Integer
Dim FirstWSToSort As Integer
Dim LastWSToSort As Integer
Dim SortDescending As Boolean
SortDescending = False
If ActiveWindow.SelectedSheets.Count = 1 Then
'Change the 1 to the worksheet you want sorted first
FirstWSToSort = 1
LastWSToSort = Worksheets.Count
Else
With ActiveWindow.SelectedSheets
For N = 2 To .Count
If .Item(N - 1).Index <> .Item(N).Index - 1 Then
MsgBox "You cannot sort non-adjacent sheets"
Exit Sub
End If
Next N
FirstWSToSort = .Item(1).Index
LastWSToSort = .Item(.Count).Index
End With
End If
For M = FirstWSToSort To LastWSToSort
For N = M To LastWSToSort
If SortDescending = True Then
If UCase(Worksheets(N).Name) > UCase(Worksheets(M).Name) Then
Worksheets(N).Move Before:=Worksheets(M)
End If
Else
If UCase(Worksheets(N).Name) < UCase(Worksheets(M).Name) Then
Worksheets(N).Move Before:=Worksheets(M)
End If
End If
Next N
Next M
Sheets("Guidelines (Read Only)").Move Before:=Sheets(1)
Sheets("Macro Control (Read Only)").Move After:=Sheets(1)
Sheets("Summary Dashboard").Move After:=Sheets(2)
Sheets("Model Engine (Read Only)").Move After:=Sheets(3)
End Sub
Code3:
Sub DeleteOldData()
'
' DeleteOldData Macro
'
'
Sheets("Model Engine (Read Only)").Select
ActiveCell.Offset(-5562, 0).Rows("1:5848").EntireRow.Select
Selection.Delete Shift:=xlUp
End Sub
Code 4:
Sub AllDataToForthSheet()
Application.ScreenUpdating = False
Dim SheetCtr As Double
Dim Last1Row As Double
Dim LastShtRow As Double
With ActiveWorkbook
For SheetCtr = 5 To .Sheets.Count
With .Worksheets(SheetCtr)
LastShtRow = .Cells(Rows.Count, "D").End(xlUp).Row
If .Cells(Rows.Count, "J").End(xlUp).Row > LastShtRow Then
LastShtRow = .Cells(Rows.Count, "G").End(xlUp).Row
End If
End With
With .Worksheets(4)
Last1Row = .Cells(Rows.Count, "F").End(xlUp).Row
If .Cells(Rows.Count, "G").End(xlUp).Row > Last1Row Then
Last1Row = .Cells(Rows.Count, "J").End(xlUp).Row
End If
End With
.Worksheets(SheetCtr).Range("D25:S" & LastShtRow).Copy
.Worksheets(4).Range("F" & Last1Row + 1).PasteSpecial xlPasteValues
Next SheetCtr
End With
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
Thanks. :):):)
How to combine moduls into single module? Below are my code for your reference.
Code 1:
Option Explicit
Public Sub ImportSheetData()
Dim sFld As String, sFlPath As String, sFile As String
Dim vPath As Variant
Dim wb As Workbook, wbThisBk As Workbook
Dim ws As Worksheet
Dim i As Integer
Application.DisplayAlerts = False
Application.ScreenUpdating = False
'For calling the deletion sub
Call DeleteOldSheets
Set wbThisBk = ThisWorkbook
'Getting the path
sFlPath = Application.GetOpenFilename("Excel Files (*.xls*), *.xls*")
If sFlPath = "False" Then
MsgBox "No Files Selected"
Exit Sub
Else
vPath = Split(sFlPath, "\")
sFld = ""
For i = LBound(vPath) To UBound(vPath)
If InStr(1, vPath(i), ".xls") = 0 Then
sFld = sFld & vPath(i) & "\"
End If
Next i
ChDir sFld
sFile = Dir("*.xls*")
Do While sFile <> ""
Set wb = Workbooks.Open(sFld & sFile)
For Each ws In wb.Sheets
ws.Copy Before:=wbThisBk.Sheets("End")
Next ws
wb.Close False
sFile = Dir
Loop
End If
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Private Sub DeleteOldSheets()
'Deleting old worksheets except Model Engine, Guidelines, Macro Control, Summary Dashboard and End
Dim ws As Worksheet
For Each ws In ThisWorkbook.Sheets
Select Case ws.Name
Case "Model Engine (Read Only)", "Guidelines (Read Only)", "Macro Control (Read Only)", "Summary Dashboard", "End"
'do nothing
Case Else
ws.Delete
End Select
Next ws
End Sub
Code 2:
Sub SortWorksheets()
Dim N As Integer
Dim M As Integer
Dim FirstWSToSort As Integer
Dim LastWSToSort As Integer
Dim SortDescending As Boolean
SortDescending = False
If ActiveWindow.SelectedSheets.Count = 1 Then
'Change the 1 to the worksheet you want sorted first
FirstWSToSort = 1
LastWSToSort = Worksheets.Count
Else
With ActiveWindow.SelectedSheets
For N = 2 To .Count
If .Item(N - 1).Index <> .Item(N).Index - 1 Then
MsgBox "You cannot sort non-adjacent sheets"
Exit Sub
End If
Next N
FirstWSToSort = .Item(1).Index
LastWSToSort = .Item(.Count).Index
End With
End If
For M = FirstWSToSort To LastWSToSort
For N = M To LastWSToSort
If SortDescending = True Then
If UCase(Worksheets(N).Name) > UCase(Worksheets(M).Name) Then
Worksheets(N).Move Before:=Worksheets(M)
End If
Else
If UCase(Worksheets(N).Name) < UCase(Worksheets(M).Name) Then
Worksheets(N).Move Before:=Worksheets(M)
End If
End If
Next N
Next M
Sheets("Guidelines (Read Only)").Move Before:=Sheets(1)
Sheets("Macro Control (Read Only)").Move After:=Sheets(1)
Sheets("Summary Dashboard").Move After:=Sheets(2)
Sheets("Model Engine (Read Only)").Move After:=Sheets(3)
End Sub
Code3:
Sub DeleteOldData()
'
' DeleteOldData Macro
'
'
Sheets("Model Engine (Read Only)").Select
ActiveCell.Offset(-5562, 0).Rows("1:5848").EntireRow.Select
Selection.Delete Shift:=xlUp
End Sub
Code 4:
Sub AllDataToForthSheet()
Application.ScreenUpdating = False
Dim SheetCtr As Double
Dim Last1Row As Double
Dim LastShtRow As Double
With ActiveWorkbook
For SheetCtr = 5 To .Sheets.Count
With .Worksheets(SheetCtr)
LastShtRow = .Cells(Rows.Count, "D").End(xlUp).Row
If .Cells(Rows.Count, "J").End(xlUp).Row > LastShtRow Then
LastShtRow = .Cells(Rows.Count, "G").End(xlUp).Row
End If
End With
With .Worksheets(4)
Last1Row = .Cells(Rows.Count, "F").End(xlUp).Row
If .Cells(Rows.Count, "G").End(xlUp).Row > Last1Row Then
Last1Row = .Cells(Rows.Count, "J").End(xlUp).Row
End If
End With
.Worksheets(SheetCtr).Range("D25:S" & LastShtRow).Copy
.Worksheets(4).Range("F" & Last1Row + 1).PasteSpecial xlPasteValues
Next SheetCtr
End With
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
Thanks. :):):)