Posts by aiwnjoo

Sub col()'
' col Macro
'




'
    With Selection.Font
        .ThemeColor = xlThemeColorDark1
        .TintAndShade = 0
    End With
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .Color = 5420131
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
End Sub












Sub fmat1()
'
' fmat1 Macro
'




'




    Selection.NumberFormat = "#,##0;[Red](#,##0);-"
End Sub




Sub fmat2()
'
' fmat1 Macro
'




'




    Selection.NumberFormat = "#,##0,;[Red](#,##0,);-"
End Sub












Sub ExcelDiet()
     
    Dim j               As Long
    Dim k               As Long
    Dim LastRow         As Long
    Dim LastCol         As Long
    Dim ColFormula      As Range
    Dim RowFormula      As Range
    Dim ColValue        As Range
    Dim RowValue        As Range
    Dim Shp             As Shape
    Dim ws              As Worksheet
     
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
     
    On Error Resume Next
     
    For Each ws In Worksheets
        With ws
             'Find the last used cell with a formula and value
             'Search by Columns and Rows
            On Error Resume Next
            Set ColFormula = .Cells.Find(What:="*", After:=Range("A1"), LookIn:=xlFormulas, _
            LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious)
            Set ColValue = .Cells.Find(What:="*", After:=Range("A1"), LookIn:=xlValues, _
            LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious)
            Set RowFormula = .Cells.Find(What:="*", After:=Range("A1"), LookIn:=xlFormulas, _
            LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious)
            Set RowValue = .Cells.Find(What:="*", After:=Range("A1"), LookIn:=xlValues, _
            LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious)
            On Error GoTo 0
             
             'Determine the last column
            If ColFormula Is Nothing Then
                LastCol = 0
            Else
                LastCol = ColFormula.Column
            End If
            If Not ColValue Is Nothing Then
                LastCol = Application.WorksheetFunction.Max(LastCol, ColValue.Column)
            End If
             
             'Determine the last row
            If RowFormula Is Nothing Then
                LastRow = 0
            Else
                LastRow = RowFormula.Row
            End If
            If Not RowValue Is Nothing Then
                LastRow = Application.WorksheetFunction.Max(LastRow, RowValue.Row)
            End If
             
             'Determine if any shapes are beyond the last row and last column
            For Each Shp In .Shapes
                j = 0
                k = 0
                On Error Resume Next
                j = Shp.TopLeftCell.Row
                k = Shp.TopLeftCell.Column
                On Error GoTo 0
                If j > 0 And k > 0 Then
                    Do Until .Cells(j, k).Top > Shp.Top + Shp.Height
                        j = j + 1
                    Loop
                    If j > LastRow Then
                        LastRow = j
                    End If
                    Do Until .Cells(j, k).Left > Shp.Left + Shp.Width
                        k = k + 1
                    Loop
                    If k > LastCol Then
                        LastCol = k
                    End If
                End If
            Next
             
            .Range(.Cells(1, LastCol + 1), .Cells(.Rows.Count, .Columns.Count)).EntireColumn.Delete
            .Range("A" & LastRow + 1 & ":A" & .Rows.Count).EntireRow.Delete
        End With
    Next
     
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
     
End Sub

Public Sub automatedFormating()Range("1:1").Delete
Range("A:A").Delete




For Each cella In Range("A1").CurrentRegion
    With cella.Font
        .Name = "Arial"
        .FontStyle = "Normál"
        .Size = 9
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ColorIndex = 1
        .TintAndShade = 0
        .ThemeFont = xlThemeFontNone
    End With
    cella.Borders(xlDiagonalDown).LineStyle = xlNone
    cella.Borders(xlDiagonalUp).LineStyle = xlNone
    With cella.Borders(xlEdgeLeft)
        .LineStyle = xlDash
        .ColorIndex = 16
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With cella.Borders(xlEdgeTop)
        .LineStyle = xlDash
        .ColorIndex = 16
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With cella.Borders(xlEdgeBottom)
        .LineStyle = xlDash
        .ColorIndex = 16
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With cella.Borders(xlEdgeRight)
        .LineStyle = xlDash
        .ColorIndex = 16
        .TintAndShade = 0
        .Weight = xlThin
    End With
    cella.Borders(xlInsideVertical).LineStyle = xlNone
    cella.Borders(xlInsideHorizontal).LineStyle = xlNone
Next




For Each cella In Range("A1:N1")
    With cella.Font
        .Name = "Arial"
        .FontStyle = "Félkövér"
        .Size = 10
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ColorIndex = 2
        .TintAndShade = 0
        .ThemeFont = xlThemeFontNone
    End With
    With cella.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .Color = 15773696
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With




Next
End Sub

Sub Replacing()






    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Cursor = xlWait
    Application.DisplayStatusBar = True
    Application.StatusBar = "Generating DM Pack, please wait!"
    
    On Error GoTo 0
    
    Dim sFile     As String
    Dim wrdApp    As Word.Application
    Dim wrdDoc    As Word.Document
    Dim sInput(0) As String, sOutput(0) As String








    sFile = "KF"
    
    Set wrdApp = New Word.Application








    With wrdApp
    
        .Visible = True
        
    Set wrdDoc = .Documents.Open("C:\Docs\" + sFile + ".doc")
    
    .Selection.Find.ClearFormatting
    .Selection.Find.Replacement.ClearFormatting
    
    sInput(0) = "Test"
    
    sOutput(0) = "ACCREF"
    
    
    For i = 0 To UBound(sInput) - 1
    
      With .Selection.Find
        .Text = sOutput(i)
        .Replacement.Text = Range(sInput(i)).Text
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = True
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
        .Execute Replace:=wdReplaceAll
        
    End With
    
    Next

Sub EmailGMAC()
    Dim wb1 As Workbook
    Dim wb2 As Workbook
    Dim TempFilePath As String
    Dim TempFileName As String
    Dim FileExtStr As String
    Dim OutApp As Object
    Dim OutMail As Object
    Set wb1 = ActiveWorkbook
    If Val(Application.Version) >= 12 Then
        If wb1.FileFormat = 51 And wb1.HasVBProject = True Then
            MsgBox "There is VBA code in this xlsx file, there will" & vbNewLine & _
                   "be no VBA code in the file you send. Save the" & vbNewLine & _
                   "file first as xlsm and then try the macro again.", vbInformation
            Exit Sub
        End If
    End If
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With
    TempFilePath = Environ$("temp") & "\"
    TempFileName = "Copy of " & wb1.Name & " " & Format(Now, "dd-mmm-yy h-mm-ss")
    FileExtStr = "." & LCase(Right(wb1.Name, _
                                   Len(wb1.Name) - InStrRev(wb1.Name, ".", , 1)))
    wb1.SaveCopyAs TempFilePath & TempFileName & FileExtStr
    Set wb2 = Workbooks.Open(TempFilePath & TempFileName & FileExtStr)
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
    On Error Resume Next
    With OutMail
        .To = Range("C2")
        .Cc = Range("C1") & ";" & "[EMAIL="[email protected]"][email protected][/EMAIL]"
        .Subject = "GMAC Referral: " & Range("C7") & " - " & Range("C9") & " - IMAGE AS GMAC REFERRAL CLOSED"
        .Body = "Please insert the following attachments: " & Range("F9") & " " & "And " & Range("G9") & "."
        Application.SendKeys "{END}"
        .Attachments.Add wb2.FullName
        .Display
    End With
    On Error GoTo 0
    wb2.Close SaveChanges:=False
    Kill TempFilePath & TempFileName & FileExtStr
    Set OutMail = Nothing
    Set OutApp = Nothing
 
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
End Sub