Snasui Excel Forum

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

macro 3 ให้เปิดอีก 2 file ให้ทำงานโดยไม่ต้องเปิดไฟล์

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

Page 1 of 1

macro 3 ให้เปิดอีก 2 file ให้ทำงานโดยไม่ต้องเปิดไฟล์

Posted: Wed May 30, 2012 5:00 pm
by godman
เราสามารถเขียน macro เพื่อให้ macro1 ของfile1 และ macro2 ของfile2 รัน แล้วไฟล์ 3 file3 รับค่ามาสรุปผล ได้ไหมครับ โดยที่ไม่เปิดเฉพาะ file3 ที่เป็นไฟล์สรุปผล ส่วน file1 และ file2 ปิดอยู่

Re: macro 3 ให้เปิดอีก 2 file ให้ทำงานโดยไม่ต้องเปิดไฟล์

Posted: Wed May 30, 2012 6:07 pm
by snasui
:D
godman wrote: โดยที่ไม่เปิดเฉพาะ file3 ที่เป็นไฟล์สรุปผล
เข้าใจว่าต้องการเปิดเฉพาะ File 3 เพราะไม่เช่นนั้นจะไม่เปิดเลยแม้แต่ไฟล์เดียว

สำหรับการ Run Macro ข้ามไฟล์สามารถทำได้ครับ ในขั้นตอนการสร้างปุ่มเพื่อ Assign Macro เราสามารถ Assign Macro ข้ามไฟลได้โดยเลือกเป็น All Open Workbooks แล้วเลือก Macro ที่อยู่ต่างไฟล์กัน หรือ เขียนเข้าไปใน Code ก็ย่อมได้ เช่นใน File3 เขียน Code เป็น

Code: Select all

Sub TestMacro()
    Application.Run "'C:\Users\Test\Desktop\Book2.xls'!TestFile01"
End Sub
เป็นการ Run Macro ที่ชื่อ TestFile01 ในไฟล์ที่ชื่อ Book2.xls ที่อยู่ใน Folder C:\Users\Test\Desktop

Re: macro 3 ให้เปิดอีก 2 file ให้ทำงานโดยไม่ต้องเปิดไฟล์

Posted: Wed May 30, 2012 6:30 pm
by godman
ขอบคุณครับ จะลองทำดู เข้าใจว่า Testfile2 ก็น่าจะเขียนหมือนกัน คือ
Sub TestMacro()
Application.Run "'C:\Users\Test\Desktop\Book2.xls'!TestFile01"
Application.Run "'C:\Users\Test\Desktop\Book3.xls'!TestFile02"

End Sub
ครับ ผมจะลองดู

Re: macro 3 ให้เปิดอีก 2 file ให้ทำงานโดยไม่ต้องเปิดไฟล์

Posted: Wed May 30, 2012 7:55 pm
by godman
อาจาย์ครับผมลองรันเฉพาะไฟล์ที่ 3 หรือตามไฟล์แนบคือไฟลนี้ ครับ

P:\DATA\FINAL\QS_Measure_Verify\QAIP_IIP_COM.xls
มันมีการ error แบบนี้ครับ
ขึ้นสีเหลือง
Worksheets("SQL-Query").Protect

Code: Select all

Public cntSQL As New ADODB.Connection
Public cmdSQL As New ADODB.Command
Public rstSQL As New ADODB.Recordset
Dim SLIfile As Variant
Dim fileSaveName As Variant
Public Param
Public ParamCheck
Public Rowcount
Public Rowstart
Public LSL
Public Tar
Public USL
Public i
Public y
Public t
Public ave
Public std
Public max
Public min
Public mean
Public subsize
Public subsqrrt
Public Sp
Public L
Public U
Public Ta
Option Explicit
Sub QueryATT()
    Dim sSheetName As String
    Dim sCell As String
    Dim sSQL As String
    Dim dCheck As String
    Dim vCheck As String
    Dim nRowIdx As Integer
    Dim sGetCell As String
    Dim sGetCriteria As String
    
    ' Protect sheet and hide activity
    Worksheets("SQL-Query").Protect
    'Application.Cursor = xlWait
    Application.ScreenUpdating = False
    
    ' Clear Previous Data
    Worksheets("SQL Data").Range("A2:O1000").ClearContents
    Worksheets("CofC").Range("A5:I35").ClearContents
    Worksheets("CofC").Range("A39:I50").ClearContents
    Worksheets("CofC").Range("B5:I35").Font.ColorIndex = 1
    Worksheets("CofC").Range("B5:I35").Font.Bold = False
    With Worksheets("CofC").Range("B5:I35").Interior
        .ColorIndex = 0
        .Pattern = xlSolid
    End With
        With Worksheets("CofC").Range("B5:I35").Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = 15
    End With
    
    Worksheets("CofC").Range("A39:I50").Font.ColorIndex = 1
    Worksheets("CofC").Range("A39:I50").Font.Bold = False
    With Worksheets("CofC").Range("A39:I50").Interior
        .ColorIndex = 0
        .Pattern = xlSolid
    End With
        With Worksheets("CofC").Range("A39:I50").Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = 15
    End With
    
    ' Open connection
    cntSQL.Open "Provider=SQLOLEDB.1;Integrated Security=SSPI;Persist Security Info=False;Initial Catalog=att;Data Source=srv-06"
    
    nRowIdx = 3 ' Start at row 3 where Query and Criteria statements begin
    
    Do
        sGetCell = "A" & Trim$(Str(nRowIdx))
        sSQL = Worksheets("SQL-Query").Range(sGetCell).Value
        If sSQL = "" Then
            Exit Do
        End If
        sGetCell = "B" & Trim$(Str(nRowIdx))
        sSheetName = Worksheets("SQL-Query").Range(sGetCell).Value
        sGetCell = "C" & Trim$(Str(nRowIdx))
        sCell = Worksheets("SQL-Query").Range(sGetCell).Value
        
        StuffCells sSQL, sSheetName, sCell
        
        nRowIdx = nRowIdx + 1
        DoEvents
    Loop
    
    Set cntSQL = Nothing
    Application.ScreenUpdating = False

    Worksheets("SQL Data").Activate
        dCheck = Range("A2")
          If dCheck = "" Then
        Worksheets("CofC").Activate
       MsgBox "No Data Found"
        Application.Cursor = xlDefault
       End
      End If

'   Move Dimension data
    Rowstart = 2
    Rowcount = 2
    Range("A1:G1").Select
    Range(Selection, Selection.End(xlDown)).Select
    Application.CutCopyMode = False
    Selection.Sort Key1:=Range("D2"), Order1:=xlAscending, Header:=xlGuess, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom

    For y = 1 To 50
    Param = Cells(Rowstart, 4)
    For i = 1 To 50
        Rowcount = Rowcount + 1
        ParamCheck = Cells(Rowcount, 4)
        If Param <> ParamCheck Then Movedimdata
        
    Next i
    
    Next y
    
'   Move XIP Data
    Rowcount = 2
    Rowstart = 2
    Range("I1:O1").Select
    Range(Selection, Selection.End(xlDown)).Select
    Application.CutCopyMode = False
    Selection.Sort Key1:=Range("L2"), Order1:=xlAscending, Header:=xlGuess, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom

    For y = 1 To 10
    Param = Cells(Rowstart, 12)
    For i = 1 To 50
        Rowcount = Rowcount + 1
        ParamCheck = Cells(Rowcount, 12)
        If Param <> ParamCheck Then Movexipdata
        
    Next i
    
    Next y
    Application.ScreenUpdating = True
    Worksheets("CofC").Activate
    MsgBox "DONE! Check the Data and Save"
    
End Sub
Sub Movedimdata()
    Set t = Range(Cells(Rowstart, 3), Cells(Rowcount - 1, 3))
    ave = Application.Average(t)
    std = Application.StDev(t)
    If Rowcount - Rowstart = 1 Then std = 0
    max = Application.max(t)
    min = Application.min(t)
    mean = Cells(Rowstart, 5)
    subsize = Cells(Rowstart, 7)
    Sp = Cells(Rowstart, 6)
    Worksheets("CofC").Cells(y + 4, 1) = Param
    Worksheets("CofC").Cells(y + 4, 2) = i
    Worksheets("CofC").Cells(y + 4, 3) = ave
    Worksheets("CofC").Cells(y + 4, 4) = std
    Worksheets("CofC").Cells(y + 4, 5) = max
    Worksheets("CofC").Cells(y + 4, 6) = min
    Worksheets("CofC").Cells(y + 4, 10) = mean
    Worksheets("CofC").Cells(y + 4, 11) = Sp
    Worksheets("CofC").Cells(y + 4, 12) = subsize
    subsqrrt = Worksheets("CofC").Cells(y + 4, 13)
    Worksheets("CofC").Activate
    Cells(y + 4, 7) = mean - (3 * (Sp / subsqrrt))
    Cells(y + 4, 9) = mean + (3 * (Sp / subsqrrt))
    Cells(y + 4, 8) = mean
    If Worksheets("CofC").Cells(y + 4, 3) < Worksheets("CofC").Cells(y + 4, 7) And Worksheets("CofC").Cells(y + 4, 7) <> "" Then
    Worksheets("CofC").Cells(y + 4, 3).Select
    Selection.Font.ColorIndex = 3
    Selection.Font.Bold = True
    With Selection.Interior
        .ColorIndex = 15
        .Pattern = xlSolid
    End With
    Selection.Borders(xlEdgeBottom).LineStyle = xlThin
    End If
    If Worksheets("CofC").Cells(y + 4, 3) > Worksheets("CofC").Cells(y + 4, 9) And Worksheets("CofC").Cells(y + 4, 9) <> "" Then
    Worksheets("CofC").Cells(y + 4, 3).Select
    Selection.Font.ColorIndex = 3
    Selection.Font.Bold = True
    With Selection.Interior
        .ColorIndex = 15
        .Pattern = xlSolid
    End With
    Selection.Borders(xlEdgeBottom).LineStyle = xlThin
    End If
   
    Worksheets("SQL Data").Activate
    Rowstart = Rowcount
    i = 50
End Sub
Sub Movexipdata()
    Set t = Range(Cells(Rowstart, 11), Cells(Rowcount - 1, 11))
    ave = Application.Average(t)
    std = Application.StDev(t)
    If Rowcount - Rowstart = 1 Then std = 0
    max = Application.max(t)
    min = Application.min(t)
    subsize = Cells(Rowstart, 15)
    mean = Cells(Rowstart, 13)
    Sp = Cells(Rowstart, 14)
    Worksheets("CofC").Cells(y + 38, 1) = Param
    Worksheets("CofC").Cells(y + 38, 2) = i
    Worksheets("CofC").Cells(y + 38, 3) = ave
    Worksheets("CofC").Cells(y + 38, 4) = std
    Worksheets("CofC").Cells(y + 38, 5) = max
    Worksheets("CofC").Cells(y + 38, 6) = min
    Worksheets("CofC").Cells(y + 38, 10) = mean
    Worksheets("CofC").Cells(y + 38, 11) = Sp
    Worksheets("CofC").Cells(y + 38, 12) = subsize
    subsqrrt = Worksheets("CofC").Cells(y + 38, 13)
    Worksheets("CofC").Activate
    Cells(y + 38, 7) = mean - (3 * (Sp / subsqrrt))
    Cells(y + 38, 9) = mean + (3 * (Sp / subsqrrt))
    Cells(y + 38, 8) = mean
    If Worksheets("CofC").Cells(y + 38, 3) < Worksheets("CofC").Cells(y + 38, 7) And Worksheets("CofC").Cells(y + 38, 7) <> "" Then
    Worksheets("CofC").Cells(y + 38, 3).Select
    Selection.Font.ColorIndex = 3
    Selection.Font.Bold = True
    With Selection.Interior
        .ColorIndex = 15
        .Pattern = xlSolid
    End With
    Selection.Borders(xlEdgeBottom).LineStyle = xlThin
    End If
    If Worksheets("CofC").Cells(y + 38, 3) > Worksheets("CofC").Cells(y + 38, 9) And Worksheets("CofC").Cells(y + 38, 9) <> "" Then
    Worksheets("CofC").Cells(y + 38, 3).Select
    Selection.Font.ColorIndex = 3
    Selection.Font.Bold = True
    With Selection.Interior
        .ColorIndex = 15
        .Pattern = xlSolid
    End With
    Selection.Borders(xlEdgeBottom).LineStyle = xlThin
    End If
   
    Worksheets("SQL Data").Activate
    Rowstart = Rowcount
    i = 50
End Sub

'Fill sheets with SQL data
Sub StuffCells(sSQL As String, sSheetName As String, sCell As String)
    Dim colCount As Integer
    Dim colIdx As Integer
    
    Set cmdSQL.ActiveConnection = cntSQL
    cmdSQL.CommandText = sSQL
    'execute the SQL query
    Set rstSQL = cmdSQL.Execute()
    
    Worksheets(sSheetName).Activate
    Range(sCell).Select
    
    'Retrieve all rows from recordset
    Do While Not rstSQL.EOF
        colCount = rstSQL.Fields.Count
        
        For colIdx = 0 To colCount - 1
            ActiveCell.Value = rstSQL.Fields(colIdx).Value
            ActiveCell.Offset(0, 1).Activate
        Next colIdx
        
        ' Set cursor to the beginning
        ActiveCell.Offset(1, -colCount).Activate
        
        rstSQL.MoveNext
    Loop
    Set rstSQL = Nothing
    Set cmdSQL = Nothing

End Sub
Sub Clearform()
    Worksheets("SQL Data").Range("A2:O1000").ClearContents
    Worksheets("CofC").Range("A5:I35").ClearContents
    Worksheets("CofC").Range("A39:I50").ClearContents
    Worksheets("CofC").Range("B1:B2").ClearContents
        Worksheets("CofC").Range("B5:I35").Font.ColorIndex = 1
    Worksheets("CofC").Range("B5:I35").Font.Bold = False
    With Worksheets("CofC").Range("B5:I35").Interior
        .ColorIndex = 0
        .Pattern = xlSolid
    End With
        With Worksheets("CofC").Range("B5:I35").Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = 15
    End With
    Worksheets("CofC").Range("A39:I50").Font.ColorIndex = 1
    Worksheets("CofC").Range("A39:I50").Font.Bold = False
    With Worksheets("CofC").Range("A39:I50").Interior
        .ColorIndex = 0
        .Pattern = xlSolid
    End With
        With Worksheets("CofC").Range("A39:I50").Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = 15
    End With
    
    Application.CutCopyMode = False
End Sub

Re: macro 3 ให้เปิดอีก 2 file ให้ทำงานโดยไม่ต้องเปิดไฟล์

Posted: Wed May 30, 2012 7:58 pm
by godman
อันนี้คือไฟล์ที่ผมต้องการให้มันรัน เมื่อกดไฟล์เมื่อกี้นี้ ให้มันทำงาน

Re: macro 3 ให้เปิดอีก 2 file ให้ทำงานโดยไม่ต้องเปิดไฟล์

Posted: Wed May 30, 2012 8:15 pm
by snasui
:lol: มันก็ไม่ควรจะได้ครับเพราะว่า Code

Code: Select all

Worksheets("SQL-Query").Protect
ที่ทำให้ Error นั้นเป็นการกระทำกับไฟล์ Attachment IP Lot Check Template15720.xls ซึ่งปิดอยู่ ไม่ใช่ไฟล์ปัจจุบันที่เปิดทำงานอยู่

ลองเขียน Code ให้เป็นเช่นนี้ครับ
  1. เรียกไฟล์ที่ปิดอยู่เปิดขึ้นมาก่อน
  2. Run Code ในไฟล์นั้น
  3. ปิดไฟล์นั้น
  4. ทำข้อ 1-3 กับไฟล์อื่น ๆ ที่มีทั้งหมด
All times are UTC+07:00
Page 1 of 1

Powered by phpBB® Forum Software © phpBB Limited