Posts by gn00588950

Option Explicit
'Function to get screen resolution
Private Declare Function GetSystemMetrics32 Lib "user32" Alias "GetSystemMetrics" (ByVal nIndex As Long) As Long 


'Functions to get DPI
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hDC As Long, ByVal nIndex As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hDC As Long) As Long
Private Const LOGPIXELSX = 88  'Pixels/inch in X
Private Const POINTS_PER_INCH As Long = 72 'A point is defined as 1/72 inches


'Return DPI
Public Function PointsPerPixel() As Double
 Dim hDC As Long
 Dim lDotsPerInch As Long


 hDC = GetDC(0)
 lDotsPerInch = GetDeviceCaps(hDC, LOGPIXELSX)
 PointsPerPixel = POINTS_PER_INCH / lDotsPerInch
 ReleaseDC 0, hDC
End Function


'Resize when Userform Initialize
Private Sub UserForm_Initialize()


Dim w As Long, h As Long
    w = GetSystemMetrics32(0) ' Screen Resolution width in points
    h = GetSystemMetrics32(1) ' Screen Resolution height in points
    With Me
        .StartUpPosition = 1
        .Width = w * PointsPerPixel * 0.85 'Userform width= Width in Resolution * DPI * 85% 
        .Height = h * PointsPerPixel * 0.85 'Userform height= Height in Resolution * DPI * 85%
    End With
     
End Sub

Option Explicit
 
Sub CopyToNewSheet()
    
    On Error Resume Next
    
    'Define Variables
    Dim Rng As Range, CL As Range, NewRng As Range, PrefixRng As Range, YesNoRng As Range, SpellCheckRng As Range
    Dim iCnt As Integer, intChoice As Integer
    Dim sData As String, NewFilePath As String, NewFileName As String
    Dim OpenFile As Workbook
    
    Application.FileDialog(msoFileDialogOpen).AllowMultiSelect = False  'Disable Multipe File Select
    intChoice = Application.FileDialog(msoFileDialogOpen).Show  'Open File Selection Dialog
    If intChoice <> 0 Then  'If Selected 1 File
        NewFilePath = Application.FileDialog(msoFileDialogOpen).SelectedItems(1)    'Get The File Path
    End If
    NewFileName = Right(NewFilePath, Len(NewFilePath) - InStrRev(NewFilePath, "\")) 'Get File Name
    If CheckFileIsOpen(NewFileName) = True Then 'Check The File Is Opened Or Not By CheckFileIsOpen Function Stated At The End
        MsgBox ("Selected File Is Opened. Please Close It Before Transfer Data.")
        Exit Sub
    End If
    Application.DisplayAlerts = False
    
    Set Rng = Application.InputBox("Input / Select Range You Want To Copy", Type:=8)    'Display Selection Dialog For Range To Copy
    If Rng Is Nothing Then Exit Sub
    Rng.Copy
    Application.ScreenUpdating = False
    
    Set OpenFile = Workbooks.Open(NewFilePath)  'Open Your Selected File
    With OpenFile
        .Sheets(1).Cells(.Sheets(1).Cells.SpecialCells(xlCellTypeLastCell).Row + 1, 1).PasteSpecial 'Paste The Selected Range To Selected File
        Application.CutCopyMode = False
    End With
    
    Set NewRng = Selection  'In Selected File, Change The Pasted Range Font Format
    NewRng.HorizontalAlignment = xlCenter
    With NewRng.Font
        .Name = "Calibri"
        .Size = 9
        .StrikeThrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ThemeColor = xlThemeColorLight1
        .TintAndShade = 0
        .ThemeFont = xlThemeFontMinor
    End With
    With NewRng.Borders 'In Selected File, Change The Pasted Range Borders Format
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With NewRng.Interior    'In Selected File, Change The Pasted Range Field Format
        .Pattern = xlNone
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
    Application.ScreenUpdating = True
    Set PrefixRng = Application.InputBox("Input / Select Range You Want To Remove Prefix", Type:=8) 'Get The Range You Want To Remove Prefix
    If PrefixRng Is Nothing Then MsgBox ("No Prefix Will Be Removed")
    Set YesNoRng = Application.InputBox("Input / Select Range You Want To Calculate Yes No", Type:=8)   'Get The Range You Want To Calculate Yes / No
    If YesNoRng Is Nothing Then MsgBox ("No Yes No Will Be Calculated")
    Set SpellCheckRng = Application.InputBox("Input / Select Range You Want To Spell Check", Type:=8)   'Get The Range You Want To Perform Spell Check
    If SpellCheckRng Is Nothing Then MsgBox ("No Spell Check Will Be Carried Out")
    
    Application.ScreenUpdating = False
    For Each CL In YesNoRng 'Check Each Cells In The Range You Selected To Perform Yes / No Calculation
        If CL.Value = 0 Then    'If Cell Value = 0 (0%), Return No At The End Last Column + 1
            Cells(CL.Row, NewRng.Columns.Count + 1) = "No"
        ElseIf CL.Value = 1 Then    'If Cell Value = 1 (100%), Return No At The End Last Column + 1
            Cells(CL.Row, NewRng.Columns.Count + 2) = "Yes"
        End If
    Next
    
    For Each CL In SpellCheckRng    'Check Each Cells In The Range You Selected To Perform Spell Check
        For iCnt = 1 To Len(CL.Text)
            If Mid(CL.Text, iCnt, 1) = " " Then 'If Text Are Splited With Space
                If Mid(CL.Text, iCnt + 1, 1) Like "[A-Z]" Then  'Then Check If Next Character Is Upper Case
                    sData = sData & Mid(CL.Text, iCnt, 1)   'If It Is Upper Case, Remain That Text
                Else    'If Not, Remove Space
                End If
            Else
                sData = sData & Mid(CL.Text, iCnt, 1)
            End If
        Next iCnt
        Cells(CL.Row, SpellCheckRng.Column) = Trim(sData)   'At The End, Remove Leading / Tailing Space
        sData = Empty
    Next
    
    iCnt = Null
    sData = Empty
    
    
    For Each CL In PrefixRng    'Check Each Cells In The Range You Selected To Remove Prefix
        For iCnt = 1 To Len(CL.Text)
            If Mid(CL.Text, iCnt, 1) Like "[0-9]" Then  'If Text Is Not Number, Remove It
                sData = sData & Mid(CL.Text, iCnt, 1)
            End If
        Next iCnt
        If Len(sData) > 0 Then
            Cells(CL.Row, PrefixRng.Column) = sData
        End If
        sData = Empty
    Next
    
    
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    
    
    MsgBox ("Consolidated Done")
    
End Sub
 
 
Function CheckFileIsOpen(chkSumfile As String) As Boolean
    
    
    On Error Resume Next
    CheckFileIsOpen = (Workbooks(chkSumfile).Name = chkSumfile)
    On Error GoTo 0
    
End Function

Option Explicit




Sub CopyToNewSheet()
    
    On Error Resume Next
    
    Dim Rng As Range, CL As Range, NewRng As Range, PrefixRng As Range, YesNoRng As Range, SpellCheckRng As Range
    Dim iCnt As Integer, intChoice As Integer
    Dim sData As String, NewFilePath As String, NewFileName As String
    Dim OpenFile As Workbook




    Application.FileDialog(msoFileDialogOpen).AllowMultiSelect = False
    intChoice = Application.FileDialog(msoFileDialogOpen).Show
    If intChoice <> 0 Then
        NewFilePath = Application.FileDialog(msoFileDialogOpen).SelectedItems(1)
    End If
    NewFileName = Right(NewFilePath, Len(NewFilePath) - InStrRev(NewFilePath, "\"))
    If CheckFileIsOpen(NewFileName) = True Then
        MsgBox ("Selected File Is Opened. Please Close It Before Transfer Data.")
        Exit Sub
    End If
    Application.DisplayAlerts = False
    
    Set Rng = Application.InputBox("Input / Select Range You Want To Copy", Type:=8)
    If Rng Is Nothing Then Exit Sub
    Rng.Copy
    Application.ScreenUpdating = False
    
    Set OpenFile = Workbooks.Open(NewFilePath)
    With OpenFile
    .Sheets(1).Cells(.Sheets(1).Cells.SpecialCells(xlCellTypeLastCell).Row + 1, 1).PasteSpecial
    Application.CutCopyMode = False
    End With
    
    Set NewRng = Selection
    NewRng.HorizontalAlignment = xlCenter
    With NewRng.Font
        .Name = "Calibri"
        .Size = 9
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ThemeColor = xlThemeColorLight1
        .TintAndShade = 0
        .ThemeFont = xlThemeFontMinor
    End With
    With NewRng.Borders
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With NewRng.Interior
        .Pattern = xlNone
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
    Application.ScreenUpdating = True
    Set PrefixRng = Application.InputBox("Input / Select Range You Want To Remove Prefix", Type:=8)
    If PrefixRng Is Nothing Then MsgBox ("No Prefix Will Be Removed")
    Set YesNoRng = Application.InputBox("Input / Select Range You Want To Calculate Yes No", Type:=8)
    If YesNoRng Is Nothing Then MsgBox ("No Yes No Will Be Calculated")
    Set SpellCheckRng = Application.InputBox("Input / Select Range You Want To Spell Check", Type:=8)
    If SpellCheckRng Is Nothing Then MsgBox ("No Spell Check Will Be Carried Out")
    
    Application.ScreenUpdating = False
    For Each CL In YesNoRng
        If CL.Value = 0 Then
            Cells(CL.Row, NewRng.Columns.Count + 1) = "No"
        ElseIf CL.Value = 1 Then
            Cells(CL.Row, NewRng.Columns.Count + 2) = "Yes"
        End If
    Next
    
    For Each CL In SpellCheckRng
        For iCnt = 1 To Len(CL.Text)
            If Mid(CL.Text, iCnt, 1) = " " Then
                If Mid(CL.Text, iCnt + 1, 1) Like "[A-Z]" Then
                    sData = sData & Mid(CL.Text, iCnt, 1)
                Else
                End If
            Else
                sData = sData & Mid(CL.Text, iCnt, 1)
            End If
        Next iCnt
        Cells(CL.Row, SpellCheckRng.Column) = Trim(sData)
        sData = Empty
    Next
     
    iCnt = Null
    sData = Empty




    For Each CL In PrefixRng
        For iCnt = 1 To Len(CL.Text)
            If Mid(CL.Text, iCnt, 1) Like "[0-9]" Then
                sData = sData & Mid(CL.Text, iCnt, 1)
            End If
        Next iCnt
        If Len(sData) > 0 Then
            Cells(CL.Row, PrefixRng.Column) = sData
        End If
        sData = Empty
    Next




    Application.ScreenUpdating = True
    Application.DisplayAlerts = True




    MsgBox ("Consolidated Done")
     
End Sub




Function CheckFileIsOpen(chkSumfile As String) As Boolean




    On Error Resume Next
    CheckFileIsOpen = (Workbooks(chkSumfile).Name = chkSumfile)
    On Error GoTo 0
    
End Function

Option Explicit




Sub CopyToNewSheet()
    
    On Error Resume Next
    
    Dim Rng As Range, CL As Range, NewRng As Range
    Dim iCnt As Integer, intChoice As Integer
    Dim sData As String, NewFilePath As String, NewFileName As String
    Dim OpenFile As Workbook




    Application.FileDialog(msoFileDialogOpen).AllowMultiSelect = False
    intChoice = Application.FileDialog(msoFileDialogOpen).Show
    If intChoice <> 0 Then
        NewFilePath = Application.FileDialog(msoFileDialogOpen).SelectedItems(1)
    End If
    NewFileName = Right(NewFilePath, Len(NewFilePath) - InStrRev(NewFilePath, "\"))
    If CheckFileIsOpen(NewFileName) = True Then
        MsgBox ("Selected File Is Opened. Please Close It Before Transfer Data.")
        Exit Sub
    End If
    Application.DisplayAlerts = False
    
    Set Rng = Application.InputBox("Input / Select Range You Want To Copy", Type:=8)
    If Rng Is Nothing Then Exit Sub
    Rng.Copy
    Application.ScreenUpdating = False
    
    Set OpenFile = Workbooks.Open(NewFilePath)
    With OpenFile
    .Sheets(1).Cells(.Sheets(1).Cells.SpecialCells(xlCellTypeLastCell).Row + 1, 1).PasteSpecial
    Application.CutCopyMode = False
    End With
    
    Set NewRng = Selection
    NewRng.HorizontalAlignment = xlCenter
    With NewRng.Font
        .Name = "Calibri"
        .Size = 9
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ThemeColor = xlThemeColorLight1
        .TintAndShade = 0
        .ThemeFont = xlThemeFontMinor
    End With
    With NewRng.Borders
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
     
    For Each CL In NewRng.Columns(10).Cells
        If CL.Value = 0 Then
            Cells(CL.Row, 16) = "No"
        ElseIf CL.Value = 1 Then
            Cells(CL.Row, 17) = "Yes"
        End If
    Next
    
    For Each CL In NewRng.Columns(4).Cells
        For iCnt = 1 To Len(CL.Text)
            If Mid(CL.Text, iCnt, 1) = " " Then
                If Mid(CL.Text, iCnt + 1, 1) Like "[A-Z]" Then
                    sData = sData & Mid(CL.Text, iCnt, 1)
                Else
                End If
            Else
                sData = sData & Mid(CL.Text, iCnt, 1)
            End If
        Next iCnt
        Cells(CL.Row, 4) = Trim(sData)
        sData = Empty
    Next
     
    iCnt = Null
    sData = Empty




    For Each CL In NewRng.Columns(3).Cells
        For iCnt = 1 To Len(CL.Text)
            If Mid(CL.Text, iCnt, 1) Like "[0-9]" Then
                sData = sData & Mid(CL.Text, iCnt, 1)
            End If
        Next iCnt
        If Len(sData) > 0 Then
            Cells(CL.Row, 3) = sData
        End If
        sData = Empty
    Next




    Application.ScreenUpdating = True
    Application.DisplayAlerts = True




    MsgBox ("Consolidated Done")
     
End Sub




Function CheckFileIsOpen(chkSumfile As String) As Boolean




    On Error Resume Next
    CheckFileIsOpen = (Workbooks(chkSumfile).Name = chkSumfile)
    On Error GoTo 0
    
End Function