Excel Forum

Code: Select all

Set rn = Workbooks("PP5-v.4.65II.xlsb").Worksheets("Start").Range("aa9")
Set CrntWorkBook = Workbooks("DataBasePP5.xlsm")

Code: Select all

	Workbooks.Open Filename:=Range("AA9").Value & "\ExcelToSGS\DataPP5\DataBasePP5.xlsm" 

Code: Select all

                    Application.DisplayAlerts = False
                    CrntWorkBook.Activate
                    CrntWorkBook.Save
                    CrntWorkBook.Close
                    Application.DisplayAlerts = True
        
                    MsgBox ("การนำเข้าข้อมูล...สำเร็จ"), vbInformation, "Information..."
                    Application.ScreenUpdating = True
                    Exit Sub

Code: Select all

Sub ImportDataName()
    Dim CrntWorkBook As Workbook 'ไฟล์ของเรา
    Dim SourceBook As Workbook 'ไฟล์ที่จะ Copy
    Dim SourceRange As Range 'range ของไฟล์ที่จะ  Copy
    Dim Destination As Range 'range ของไฟล์ที่จะวาง
    Dim rn As Range
    Dim i As Integer, ii As Integer, iii As Integer, aa As Integer
    MsgBox ("โปรดรอสักครู่...จนกว่าระบบจะนำเข้าข้อมูลสำเร็จ !!!"), vbInformation, "Information..."
    Workbooks.Open Filename:=Range("AA9").Value & "\ExcelToSGS\DataPP5\DataBasePP5.xlsm"  'เปิดไฟล์  Database
    Set rn = Workbooks("PP5-v.4.65II.xlsb").Worksheets("Start").Range("aa9")
    Set CrntWorkBook = Workbooks("DataBasePP5.xlsm")
    
        Application.ScreenUpdating = False
        Worksheets("DBStudent").Select
        CrntWorkBook.Worksheets("DBStudent").Unprotect Password:="123456789"
        CrntWorkBook.Worksheets("DBStudent").Range("G5", "X10000").ClearContents

     With Application.FileDialog(msoFileDialogOpen)
        .Title = "เลือก File รายชื่อที่ต้องการนำเข้า !!!!  "
        .InitialFileName = ThisWorkbook.Path & "\"
        .Filters.Clear
        .Filters.Add "Excel Files", "*.xls*;*.xlsx*;*.xlsm*;*.xlsb*"
        .AllowMultiSelect = False
        .Show
         
        If .SelectedItems.Count > 0 Then
                Workbooks.Open .SelectedItems(1)
                Set SourceBook = ActiveWorkbook
                
                SourceBook.Activate
                i = Application.WorksheetFunction.CountA(SourceBook.Worksheets("sheet1").Range("A:A"))
                Set SourceRange = SourceBook.Worksheets("sheet1").Range("A2", "N" & i)   'range ของไฟล์ที่จะ  Copy
                
                CrntWorkBook.Activate
                'Call UnprotectSh
                CrntWorkBook.Save
                Set Destination = CrntWorkBook.Worksheets("DBStudent").Range("G5")  'range ของไฟล์ที่จะวาง
                SourceRange.Copy   'Destination
                Destination.PasteSpecial xlPasteValues
                Application.CutCopyMode = False
                SourceBook.Close SaveChanges:=False
           
        'ใส่สูตรในเซลล์
         ii = Application.WorksheetFunction.CountA(Workbooks("DatabasePP5").Worksheets("DBStudent").Range("G5:G10000")) + 4 'นับเซลล์ทีมีข้อมูลจริง
        CrntWorkBook.Worksheets("DBStudent").Range("U5", "U" & ii).Formula = "=IF(OR(Q5=""เด็กชาย"",Q5=""นาย""),1,2)"  'เพศ
        CrntWorkBook.Worksheets("DBStudent").Range("V5", "V" & ii).Formula = "=RIGHT(H5)&I5"  'ชั้น/ห้อง
        CrntWorkBook.Worksheets("DBStudent").Range("W5", "W" & ii).Formula = "=V5&U5&P5"  'code เรียงลำดับ
        CrntWorkBook.Worksheets("DBStudent").Range("X5", "X" & ii).Formula = "=IF(V5=nameST!$B$1,MAX($X$4:X4)+1,"""")"  'No.new
        
    'เรียงลำดับ
        Workbooks("DataBasePP5").Worksheets("DBStudent").Sort.SortFields.Add Key:=Range( _
        "W4", "W" & ii), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal   'เงื่อนไขที่ 1
            With CrntWorkBook.Worksheets("DBStudent").Sort
                .SetRange Range("G4", "X" & ii)
                .Header = xlYes
               .MatchCase = False
                .Orientation = xlTopToBottom
                .SortMethod = xlPinYin
                .Apply
            End With
                    Application.DisplayAlerts = False
                    CrntWorkBook.Activate
                    CrntWorkBook.Save
                    CrntWorkBook.Close
                    Application.DisplayAlerts = True
        
                    MsgBox ("การนำเข้าข้อมูล....สำเร็จ"), vbInformation, "Information..."
                    Application.ScreenUpdating = True
                    Exit Sub

            Else
                MsgBox ("คุณครูยังไม่ได้เลือกไฟล์รายชื่อที่ต้องการนำเข้า !!!! "), vbCritical 'ถ้าไม่ได้เลือกไฟล์
            End If
        End With

End Sub

Code: Select all

Workbooks.Open Filename:="E:\ExcelToSGS\DataPP5\DataBasePP5.xlsm"