Snasui Excel Forum

คลังคำตอบแห่งความรู้จากคนไทย เพื่อโลกที่ต้องการเข้าใจในสิ่งเล็ก ๆ อย่างลึกซึ้ง
https://snasui.com/

ปรับโค๊ดยังให้ให้คำนวณไวขึ้น

https://snasui.com/viewtopic.php?t=10834

Page 1 of 1

ปรับโค๊ดยังให้ให้คำนวณไวขึ้น

Posted: Mon Nov 07, 2016 7:19 pm
by semikolon

Code: Select all

Sub AddOrderStock()
Dim A
Dim B
Set A = Range("Table110[ÃËÑÊÊÔ¹¤éÒ]")
Set B = Range("A13")
On Error Resume Next
If V = Application.WorksheetFunction.VLookup(B, A, 1, False) Then
    If Range("A13") = "/x" Then
    MsgBox "¤Ø³·ÓÃÒ¡ÒÃäÁè¶Ù¡µéͧ"
    End
    End If
    If MsgBox("ÃËÑÊÊÔ¹¤éÒÊÒÁÒöãªéä´é", vbOKCancel + vbQuestion, "ÃËÑÊÊÔ¹¤éÒ") = vbOK Then
    Range("B13:F13").Select
    Selection.Copy
    Range("B65536").End(xlUp).Offset(1, 0).Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("H13").Select
    Selection.Copy
    Range("Table110[ÃËÑÊÊÔ¹¤éÒ]").End(xlDown).Offset(0, 7).Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
'refresh
    Range("B13:F13,H13").Select
    Selection.ClearContents
    
'Add New Sheet
    Sheets.Add After:=Sheets(Sheets.Count)
    ActiveCell.FormulaR1C1 = "ÃËÑÊÊÔ¹¤éÒ"
    Range("A4").Select
    ActiveCell.FormulaR1C1 = "Çѹ·Õè"
    Range("B4").Select
    ActiveCell.FormulaR1C1 = "ÃÒ¡ÒÃ"
    Range("C4").Select
    ActiveCell.FormulaR1C1 = "àÅ¢·ÕèãºÊÑ觫×éÍ"
    Range("D4").Select
    ActiveCell.FormulaR1C1 = "àÅ¢·ÕèãºàʹÍÃÒ¤Ò"
    Range("E4").Select
    ActiveCell.FormulaR1C1 = "àÅ¢·Õè¼ÅÔµ"
    Range("F4").Select
    ActiveCell.FormulaR1C1 = "¨Ó¹Ç¹ÃѺ"
    Range("G4").Select
    ActiveCell.FormulaR1C1 = "¨Ó¹Ç¹¨èÒÂ"
    Range("H4").Select
    ActiveCell.FormulaR1C1 = "¤§àËÅ×Í"
    Range("I4").Select
    ActiveCell.FormulaR1C1 = "¨Ó¹Ç¹àÈÉ"
    Range("J4").Select
    ActiveCell.FormulaR1C1 = "ÃÒ¤Ò"
    Range("A4:J5").Select
    ActiveSheet.ListObjects.Add(xlSrcRange, Range("$A$4:$J$5"), , xlYes).Name = _
        "Table.Count"
    Application.WindowState = xlMaximized
    ActiveSheet.ListObjects("Table.Count").TableStyle = "TableStyleMedium8"
    Application.Left = 1
    Application.Top = 1
    Application.Width = 512.25
    Application.Height = 553.5
    Range("E1").Select
    ActiveCell.FormulaR1C1 = "µÑ駵é¹"
    Range("F1").Select
    ActiveCell.FormulaR1C1 = "ÃѺ·Ñé§ËÁ´"
    Range("G1").Select
    ActiveCell.FormulaR1C1 = "¨èÒ·Ñé§ËÁ´"
    Range("H1").Select
    ActiveCell.FormulaR1C1 = "¤§àËÅ×Í"
    Range("I1").Select
    ActiveCell.FormulaR1C1 = "àËÅ×ÍàÈÉ"
    Range("E1:I2").Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    Range("E1:I1").Select
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorLight1
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
    With Selection.Font
        .ThemeColor = xlThemeColorDark1
        .TintAndShade = 0
    End With
    Range("F2").Select
    Selection = "=SUM(F5:F999999)"
    Range("G2").Select
    Selection = "=SUM(G5:G999999)"
    Range("H2").Select
    Selection = "=E2+F2-G2"
    Range("I2").Select
    Selection = "=SUM(I5:I999999)"
         'ÅÔé§Ë¹éÒáá
    Range("J2").Select
    ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:="", SubAddress:= _
        "á¼è¹!A1", TextToDisplay:="¡ÅѺ˹éÒáá"
    'ÅÔé§ÃËÑÊÊÔ¹¤éÒÊØ´·éÒÂ
    Worksheets("á¼è¹").Select
    Dim m
   m = Sheets.Count - 1
   If MsgBox("¤Ø³µéͧ¡ÒÃàª×èÍÁ⧡Ѻ Sheet" & m & " ãªèËÃ×ÍäÁè ?", vbOKCancel, "Hyperlink") = vbOK Then
   Range("Table110[ÃËÑÊÊÔ¹¤éÒ]").End(xlDown).Select
   ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:="", SubAddress:= _
        "Sheet" & m & "!A1"
    Range("Table110[ÃËÑÊÊÔ¹¤éÒ]").End(xlDown).Offset(0, 9).Select
    Selection = "=Sheet" & m & "!E2"
   Range("Table110[ÃËÑÊÊÔ¹¤éÒ]").End(xlDown).Offset(0, 10).Select
     Selection = "=Sheet" & m & "!F2"
    Range("Table110[ÃËÑÊÊÔ¹¤éÒ]").End(xlDown).Offset(0, 11).Select
     Selection = "=Sheet" & m & "!G2"
    Range("Table110[ÃËÑÊÊÔ¹¤éÒ]").End(xlDown).Offset(0, 12).Select
    Selection = "=Sheet" & m & "!H2"
    Range("Table110[ÃËÑÊÊÔ¹¤éÒ]").End(xlDown).Offset(0, 13).Select
    Selection = "=Sheet" & m & "!I2"
    Range("Table110[ÃËÑÊÊÔ¹¤éÒ]").End(xlDown).Select
    Selection.Copy
    Selection.Hyperlinks(1).Follow NewWindow:=False, AddHistory:=True
    Range("B1").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    End If
    
    
    'save
        ActiveWorkbook.Save
        MsgBox "ºÑ¹·Ö¡ÊÓàÃç¨"
    End If
Else
If MsgBox("ÃËÑÊÊÔ¹¤éÒ " & B & " ÁÕÍÂÙèáÅéÇ" & vbCrLf & "µéͧ¡ÒÃä»Âѧ˹éҺѹ·Ö¡¢éÍÁÙÅËÃ×ÍäÁè ?", vbOKCancel + vbQuestion, "µÃÃǨÊͺÃËÑÊÊÔ¹¤éÒ") = vbOK Then
   Dim r
For r = 16 To 65536
On Error Resume Next
If Cells(r, 1) = Range("A13") Then
'MsgBox ("á¶Ç·Õè" & r)
Cells(r, 1).Select
Selection.Hyperlinks(1).Follow NewWindow:=False, AddHistory:=True
Exit For
Cells(r, 1).Select
End If
Next r
End If
End If
End Sub
จากโค๊ดด้านบนที่ผมลองเขียน และนำไปใช้งาน ช่วงแรกก็ใช้งานได้ปกติ แต่พอใช้ไปๆ ก็มีข้อความขึ้นว่า "ทรัพยากรระบบไม่มีทรัพยากรระบบไม่เพียงพอที่จะแสดงผลได้อย่างสมบูรณ์" ผมคาดว่าน่าจะเป็นเพราะ RAM ไม่พอ แต่อยากให้ช่วยแนะนำว่าจะสามารถปรับโค๊ดให้มีการคำนวณได้เร็วกว่านี้มั้ยครับ รบกวนผู้รู้แนะนำทีครับ ผมแนบไฟล์ไว้ด้วย

Re: ปรับโค๊ดยังให้ให้คำนวณไว้ขึ้น

Posted: Mon Nov 07, 2016 7:41 pm
by snasui
:D ช่วยอธิบายว่าช้าในขั้นตอนไหน อย่างไร บอกค่าที่จำเป็นต้องใช้และวิธีการทดสอบมาด้วยครับ

การเพิ่มชีตไปเรื่อย ๆ ย่อมกินทรัพยากร ไม่ทราบว่ามีเหตุผลใดที่ต้องเพิ่มชีตไปเรื่อย ๆ แทนการวางในชีตใดชีตหนึ่งครับ

Re: ปรับโค๊ดยังให้ให้คำนวณไวขึ้น

Posted: Tue Nov 08, 2016 4:16 am
by semikolon
>>ในชีทแรก จะทำการป้อนค่าลงในช่อง B13, C13, D13, E13, F13 และ H13 ครับ จากนั้นทำการคลิกปุ่ม "กดเพิ่มรายการ" ตัวโค๊ดจะทำการรันนำข้อมมูลที่กรอกไปเพิ่มลงที่บรรทัดสุดท้ายของตารางด้านล่างในหน้าแรก และจะสร้างชีทขึ้นมาใหม่ 1 ชีท โดยในหน้าชีทใหม่จะสร้างแบบฟอร์มที่เขียนไว้และบันทึกข้อมูลที่ได้ป้อนไว้ จากนั้นจะทำการลิ้งค์เชื่อมโยงระหว่างชีทหน้าแรกกับชีทที่เพิ่มใหม่ครับ
>>เหตุผลที่ต้องเพิ่มชีทใหม่ เพื่อใช้ลงรายละเอียดในการเบิก-จ่ายผลิตภัณฑ์ชนิดนั้นๆครับ

Re: ปรับโค๊ดยังให้ให้คำนวณไวขึ้น

Posted: Tue Nov 08, 2016 6:27 pm
by snasui
:D ตัวอย่างการปรับ Code ตามด้านล่างครับ

Code: Select all

Sub AddOrderStock()
    Dim A As Range, B As Range
    Set A = Range("Table110[รหัสสินค้า]")
    Set B = Range("A13")
    'On Error Resume Next
    If Application.WorksheetFunction.CountIf(A, B) = 0 Then
        If Range("A13") = "/x" Then
            MsgBox "คุณทำรายการไม่ถูกต้อง"
            End
        End If
        If MsgBox("รหัสสินค้าสามารถใช้ได้", vbOKCancel + vbQuestion, "รหัสสินค้า") = vbOK Then
        
            Range("B65536").End(xlUp).Offset(1, 0).Value = Range("B13:F13").Value
            Range("Table110[รหัสสินค้า]").End(xlDown).Offset(0, 7).Value = Range("H13").Value
            'refresh
            Range("B13:F13,H13").ClearContents
            
            'Add New Sheet
            Sheets.Add After:=Sheets(Sheets.Count)
            Range("A4:I4").Value = Array("รหัสสินค้า", "วันที่", "รายการ", "เลขที่ใบสั่งซื้อ", "เลขที่ใบเสนอราคา", _
                "เลขที่ผลิต", "จำนวนรับ", "จำนวนจ่าย", "คงเหลือ", "จำนวนเศษ", "ราคา")
            ActiveSheet.ListObjects.Add(xlSrcRange, Range("$A$4:$J$5"), , xlYes).Name = _
                "Table.Count"
            With Application
                .WindowState = xlMaximized
                .ActiveSheet.ListObjects("Table.Count").TableStyle = "TableStyleMedium8"
            End With
            
            Range("E1:I1").Value = Array("ตั้งต้น", "รับทั้งหมด", "จ่ายทั้งหมด", "คงเหลือ", "เหลือเศษ")
            
            With Range("E1:I2")
                Selection.Borders(xlDiagonalDown).LineStyle = xlNone
                Selection.Borders(xlDiagonalUp).LineStyle = xlNone
                .Borders(xlEdgeLeft).LineStyle = xlContinuous
                .Borders(xlEdgeTop).LineStyle = xlContinuous
                .Borders(xlEdgeBottom).LineStyle = xlContinuous
                .Borders(xlEdgeRight).LineStyle = xlContinuous
                .Borders(xlInsideVertical).LineStyle = xlContinuous
                .Borders(xlInsideHorizontal).LineStyle = xlContinuous
            End With
            With Range("E1:I1")
                With .Interior
                    .Pattern = xlSolid
                    .PatternColorIndex = xlAutomatic
                    .ThemeColor = xlThemeColorLight1
                    .TintAndShade = 0
                    .PatternTintAndShade = 0
                End With
                With .Font
                    .ThemeColor = xlThemeColorDark1
                    .TintAndShade = 0
                End With
            End With
            Range("F2").Formula = "=SUM(F5:F999999)"
            Range("G2").Formula = "=SUM(G5:G999999)"
            Range("H2").Formula = "=E2+F2-G2"
            Range("I2").Formula = "=SUM(I5:I999999)"
                 'ลิ้งหน้าแรก
            Range("J2").Hyperlinks.Add Anchor:=Selection, Address:="", SubAddress:= _
                "แผ่น!A1", TextToDisplay:="กลับหน้าแรก"
            'ลิ้งรหัสสินค้าสุดท้าย
            Worksheets("แผ่น").Select
            Dim m As Long
            m = Sheets.Count - 1
           
           If MsgBox("คุณต้องการเชื่อมโยงกับ Sheet" & m & " ใช่หรือไม่ ?", vbOKCancel, "Hyperlink") = vbOK Then
                Range("Table110[รหัสสินค้า]").End(xlDown).Select
                ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:="", SubAddress:= _
                     "Sheet" & m & "!A1"
                 Range("Table110[รหัสสินค้า]").End(xlDown).Offset(0, 9).Formula = "=Sheet" & m & "!E2"
                 Range("Table110[รหัสสินค้า]").End(xlDown).Offset(0, 10).Formula = "=Sheet" & m & "!F2"
                 Range("Table110[รหัสสินค้า]").End(xlDown).Offset(0, 11).Formula = "=Sheet" & m & "!G2"
                 Range("Table110[รหัสสินค้า]").End(xlDown).Offset(0, 12).Formula = "=Sheet" & m & "!H2"
                 Range("Table110[รหัสสินค้า]").End(xlDown).Offset(0, 13).Formula = "=Sheet" & m & "!I2"
                 Range("Table110[รหัสสินค้า]").End(xlDown).Select
                 Selection.Copy
                 Selection.Hyperlinks(1).Follow NewWindow:=False, AddHistory:=True
                 Range("B1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                     :=False, Transpose:=False
                Application.CutCopyMode = False
            End If
            
            'save
            ActiveWorkbook.Save
            MsgBox "บันทึกสำเร็จ"
        End If
    Else
        If MsgBox("รหัสสินค้า " & B & " มีอยู่แล้ว" & vbCrLf & "ต้องการไปยังหน้าบันทึกข้อมูลหรือไม่ ?", _
            vbOKCancel + vbQuestion, "ตรรวจสอบรหัสสินค้า") = vbOK Then
            Dim r As Long
            For r = 16 To 65536
                On Error Resume Next
                If Cells(r, 1) = Range("A13") Then
                    'MsgBox ("แถวที่" & r)
                    Cells(r, 1).Hyperlinks(1).Follow NewWindow:=False, AddHistory:=True
                    Exit For
                    'Cells(r, 1).Select
                End If
            Next r
        End If
    End If
End Sub
All times are UTC+07:00
Page 1 of 1

Powered by phpBB® Forum Software © phpBB Limited