BOU Marco

Business unit overview

Sub BUOVW()
Call RetrieveFile
Call forsheetscreation
Call copycomplexdataintomaster
Call todeletedefaluts
Call toreplaceNA
Call TransferData
End Sub

Sub RetrieveFile() ' to populate  message if files are not there

file = ThisWorkbook.Path & "\1.Raw Files\*.*"
'file = Dir("\\c\aku4\Desktop\Business unit overview\TEST\*.*")
If Len(file) > 0 Then
 MsgBox (" Files are Exists.. and continuing the macro")
Else
 MsgBox ("File Doesn't Exists")
End If
End Sub

' to get each and every file name
Sub paths()
Dim objFSO As Object
Dim objFolder As Object
Dim objFile As Object
Dim i As Integer
file = ThisWorkbook.Path & "\1.Raw Files"
'Create an instance of the FileSystemObject
Set objFSO = CreateObject("Scripting.FileSystemObject")
'Get the folder object
'Set objFolder = objFSO.GetFolder("\\c\aku4\Desktop\Business unit overview\TEST")
Set objFolder = objFSO.GetFolder(file)
i = 1
'loops through each file in the directory and prints their names and path
For Each objFile In objFolder.Files
    'print file name
    Sheets(2).Cells(i, 1) = objFile.Name
    'print file path
    Sheets(2).Cells(i, 2) = objFile.Path
    i = i + 1
     
Next objFile
End Sub

'to create spreadsheets
Sub forsheetscreation()
Call paths
file = ThisWorkbook.Path & "\1.Raw Files"
Dim lrow As Long
lrow = Sheets(2).UsedRange.Rows.Count

Sheets(2).Activate
For i = 1 To lrow
If i <= lrow Then
    ChDir file
    'ChDir "\\c\aku4\Desktop\Business unit overview\TEST"
 
'    Workbooks.OpenText Filename:= _
'        "\\\c\aku4\\Desktop\Business unit overview\TEST\" & Range("a" & i) & "*.*", Origin _
'        :=437, StartRow:=1, DataType:=xlDelimited, TextQualifier:=xlDoubleQuote _
'        , ConsecutiveDelimiter:=False, Tab:=True, Semicolon:=False, Comma:= _
'        False, Space:=False, Other:=True, OtherChar:="|", FieldInfo:=Array( _
'        Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1)), TrailingMinusNumbers:=True
'
'
        Workbooks.OpenText Filename:= _
        file & "\" & Range("a" & i) & "*.*", Origin _
        :=437, StartRow:=1, DataType:=xlDelimited, TextQualifier:=xlDoubleQuote _
        , ConsecutiveDelimiter:=False, Tab:=True, Semicolon:=False, Comma:= _
        False, Space:=False, Other:=True, OtherChar:="|", FieldInfo:=Array( _
        Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1)), TrailingMinusNumbers:=True
     
     
     
    a = Range("a1").Value
    If a = "Sector Name " Then
        a = " Complex sector Weights"
        Else
        a = Range("B1").Value
        End If
    'ActiveCell.FormulaR1C1 = a
 
    file1 = ThisWorkbook.Path & "\2.Results\"
    ChDir file1
    'ChDir "\\\c\aku4\\Desktop\Business unit overview\MASTER"
    ActiveWorkbook.SaveAs Filename:= _
        file1 & a, _
        FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
    ActiveWindow.Close
 
End If
Next i

End Sub
'To Delete Default string in the range and NA has to replace with blank
'Range("a1").CurrentRegion.EntireRow.Delete
Sub todeletedefaluts()
Dim sstring As String
Dim i As Integer
        For i = 1 To 600
        sstring = Range("a" & i)
        If Trim(sstring) = "Default" Then
            Range("a" & i).EntireRow.Delete
           End If
Next
End Sub

'to relace with NA with blanks
Sub toreplaceNA()
Dim nastring As String
Dim i As Integer
    For i = 1 To 600
    nastring = Range("c" & i)
    If Trim(nastring) = "NA" Then
    Range("c" & i) = ""
    End If
    Next

End Sub
'to Transfer the data from complex weights to buinsines unit chart
Sub TransferData()
    Dim strPath1 As String
    Dim strPath2 As String
    Dim wb2 As Workbook
 
    'define paths and filenames
    strPath1 = ThisWorkbook.Path & "\2.Results\MASTER-EUA.XSLM"
    'strPath1 = \\\c\aku4\\Desktop\Business unit overview\MASTER\\MASTER.xlsm"
    strPath2 = ThisWorkbook.Path & "\2.Results\Copy of business unit chart data.xls"
    'strPath2 = "\\\c\aku4\\Desktop\Business unit overview\MASTER\Copy of business unit chart data.xls"

    'open files
    'Set wbkWorkbook1 = Workbooks(strPath1)
    Set wb2 = Workbooks.Open(strPath2)
     
Workbooks("MASTER-EUA.xlsm").Activate
Set wb1 = Workbooks("MASTER-EUA.xlsm")
Set wb2 = Workbooks("Copy of business unit chart data.xls")
lastrow = 1

If Sheets("sheet1").Range("a1") <> "" Then

TODO:

If Sheets("Sheet1").Range("a1").Value = "SubInd Name " Then

    Sheets(1).Range("a1").CurrentRegion.Select
    Selection.AutoFilter
    Sheets(1).Range("A1").AutoFilter Field:=2, Criteria1:="10", Operator:=xlTop10Items
    Sheets(1).Range("a1").CurrentRegion.Copy wb2.Worksheets("grouped data").Range("f" & lastrow)
    Worksheets(1).AutoFilterMode = False
    Sheets(1).Range("a1").CurrentRegion.EntireRow.Delete
    lastrow = wb2.Worksheets("grouped data").Range("b1").SpecialCells(xlCellTypeLastCell).Row
    lastrow = lastrow + 2


            ElseIf Sheets("Sheet1").Range("a1").Value = "Region Name " Then
         
            Sheets(1).Range("a1").CurrentRegion.Select
            Sheets(1).Range("a1").CurrentRegion.Copy wb2.Worksheets("grouped data").Range("j" & lastrow)
            Range("a1").CurrentRegion.EntireRow.Delete
            lastrow = wb2.Worksheets("grouped data").Range("j1").SpecialCells(xlCellTypeLastCell).Row
            lastrow = lastrow + 7
         
Else

        Sheets(1).Range("a1").CurrentRegion.Select
        Selection.AutoFilter
        Sheets(1).Range("A1").AutoFilter Field:=2, Criteria1:="10", Operator:=xlTop10Items
        Sheets(1).Range("a1").CurrentRegion.Copy wb2.Worksheets("grouped data").Range("b" & lastrow)
        Worksheets(1).AutoFilterMode = False
        Sheets(1).Range("a1").CurrentRegion.EntireRow.Delete
        lastrow = wb2.Worksheets("grouped data").Range("b1").SpecialCells(xlCellTypeLastCell).Row
        lastrow = lastrow + 2

        End If
End If

If Sheets(1).Range("A2") <> "" Then
Sheets(1).Range("a1").EntireRow.Delete
GoTo TODO:
End If
wb2.Activate
Call bring_datatogether

End Sub

Sub copycomplexdataintomaster()
 Dim Path1 As String
 Dim wb As Workbook

Path1 = ThisWorkbook.Path & "\2.Results\" & " Complex sector Weights.xlsx"
    'Path1 = "\\\c\aku4\\Desktop\Business unit overview\MASTER\ Complex sector Weights.xlsx"
    Set wb = Workbooks.Open(Path1)
    Workbooks("MASTER-EUA.xlsm").Worksheets("Sheet1").Activate
    wb.Sheets(1).Range("A:E").Copy Sheets(1).Range("a1")
     Workbooks(" Complex sector Weights.xlsx").Close
   
End Sub

Sub bring_datatogether()

Dim a As Integer
Workbooks("Copy of business unit chart data.xls").Activate
Sheets("grouped data").Select
a = Range("f1").End(xlDown).Row
a = a - 1
Range("f1:H" & a).Select
Selection.Delete shift:=xlUp
b = Range("j1").End(xlDown).Row
b = b - 1
Range("j1:l" & b).Select
Selection.Delete shift:=xlUp
End Sub

Sub Copy_to_RespTempt() 'to copy the data to resepective templates
Dim q, w As Integer
Dim sstr As String
Path1 = ThisWorkbook.Path & "\3.Data\"
path2 = ThisWorkbook.Path & "\2.Results\"

Workbooks("Master-EUA.xlsm").Activate
Sheets(3).Select
k = Range("a2").CurrentRegion.Rows.Count

For q = 2 To k
sstr = Sheets(3).Range("a" & q)
    Set wb = Workbooks.Open(path2) & sstr
    MsgBox wb

Next
End Sub

Comments

Post a Comment

Popular posts from this blog

number format

  Selection.NumberFormat = "0.00" --------------- =OFFSET(G1094,-1,0)/OFFSET(G1094,-12,0)-1 ---------------- Sub test() ' to select all sheets in the summary workbook Dim i As Long Sheet1.Select For i = 2 To ThisWorkbook.Sheets.Count     If Sheets(i).Name <> "Summary" Then Sheets(i).Select Replace:=False Next i End Sub  --------------- Sub LastRowInOneColumn()  'Find the last used row in a Column: column F in this     Dim LastRow As Long     With ActiveSheet         LastRow = .Cells(.Rows.Count, "F").End(xlUp).Row     End With     MsgBox LastRow End Sub --------------------------------- Sub tests() ' to place vlookup in each and every sheet other than summary Dim i As Long Sheet1.Select For i = 2 To ThisWorkbook.Sheets.Count     If Sheets(i).Name <> "Summary" Then Sheets(i).Select Replace:=False     a = Range("f7").End(xlDown).Row ...
Read more

send Mail by outlook from excel sheet

Sub outlookmailxlsheet()     Dim rng As Range     Dim OutApp As Object     Dim OutMail As Object       Set rng = Nothing     Set rng = Sheets("YourSheet").UsedRange     Set OutApp = CreateObject("Outlook.Application")     Set OutMail = OutApp.CreateItem(0)     On Error Resume Next     With OutMail         .To = "XX@gmail.com"         .CC = ""         .BCC = ""         .Subject = "This is the Subject line"         .HTMLBody = RangetoHTML(rng)         .Send   'or use .Display     End With     With Application         .EnableEvents = True         .ScreenUpdating = True     End With     Set OutMail = Nothing     Set OutApp = Nothing End Sub Fun...
Read more

Find and copy the data

Sub CLE() 'ONEYEAR DATA Sheets("Sheet2").Select 'Range("j10: L110 ").ClearContents 'FSTR = InputBox("Enter the date.. You wanted to See !") lastrow = Sheets("sheet2").UsedRange.Rows.Count On Error GoTo sant For I = 6 To lastrow If Range("C" & I) <> "" Then fstr = Sheets("sheet2").Range("c" & I).Value Sheets("Sheet1").Select             Cells.Find(What:=fstr, After:=ActiveCell, _             LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, _             SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False).Activate             'ActiveCell.CurrentRegion.Select A = ActiveCell.Row 'MsgBox A + 2 A = A + 2 Range("f" & A).Select     Selection.Copy     Sheets("Sheet2").Select     Range("e" & I).Select     Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, ...
Read more