VBA-偽SQL從多個工作表提取數據後分析的方法

Sub 偽SQL數據導入()

    Application.ScreenUpdating = False

For Each wk In Workbooks '關閉工作表

    If Left(wk.Name, 2) = "in" Or Left(wk.Name, 2) = "so" Then wk.Close

Next

    pth = ThisWorkbook.Path

    Set fso = CreateObject("Scripting.FileSystemObject").GetFolder(pth)

    For Each File In fso.Files

        If Left(File.Name, 2) = "in" Or Left(File.Name, 2) = "so" Then

        a = 0

        End If

        a = a 1

    Next

    If a <> 3 Then

    Call 定時關閉的對話框

    Exit Sub

    End If

    Set WS = Sheets("滙縂")

    WS.Select

    WS.Visible = True

    WS.Cells.Clear

    Cells(1, 1) = "判斷"

    Cells(1, 2) = "控制鍵"

    Cells(1, 3) = "等級"

    Cells(1, 4) = "客戶簡稱"

    Cells(1, 5) = "制造商"

    Cells(1, 6) = "客戶槼格"

    Cells(1, 7) = "厚度"

    Cells(1, 8) = "寬度"

    Cells(1, 9) = "長度"

    Cells(1, 10) = "受注指示重量"

    Cells(1, 11) = "重量"

    Cells(1, 12) = "發貨日期"

    Cells(1, 13) = "品種"

    Cells(1, 14) = "銷售方式"

    Cells(1, 15) = "轉廠"

    Call FavoriteArrayList

End Sub

Private Sub FavoriteArrayList()

    Dim ArrayList(14) As String

    ArrayList(1) = "控制鍵"

    ArrayList(2) = "等級"

    ArrayList(3) = "客戶簡稱"

    ArrayList(4) = "制造商"

    ArrayList(5) = "客戶槼格"

    ArrayList(6) = "厚度"

    ArrayList(7) = "寬度"

    ArrayList(8) = "長度"

    ArrayList(9) = "受注指示重量"

    ArrayList(10) = "重量"

    ArrayList(11) = "發貨日期"

    ArrayList(12) = "品種"

    ArrayList(13) = "銷售方式"

    ArrayList(14) = "轉廠"

    Run ArrayList()

End Sub

Private Sub Run(ArrayList() As String)

    On Error Resume Next

    Dim Wb As Workbook

    Dim Temp As String

    Dim WS As Worksheet

    Dim counter As Integer

    Set WS = Sheets("滙縂")

    pth = ThisWorkbook.Path

    TWN = ThisWorkbook.Name

    Set fso = CreateObject("Scripting.FileSystemObject").GetFolder(pth)

    For Each File In fso.Files

        If Left(File.Name, 2) = "in" Or Left(File.Name, 2) = "so" Then

            Set Wb = GetObject(pth & "\" & File.Name)

            If WS.[D1].Value = "" Then

                last_row = 1

            Else

                last_row = WS.Range("D" & Rows.Count).End(xlUp).Row 1

            End If

            For counter = 1 To 14

                Wb.Sheets(1).Activate

                RC = Rows(1).Find(ArrayList(counter), LookAt:=xlWhole).Column

                If RC = XX Then GoTo 防錯

                ZZ = Cells(1).Cells(Rows.Count, RC).End(xlUp).Row

                Range(Cells(2, RC), Cells(ZZ, RC)).COPY WS.Cells(last_row, counter 1)

                XX = RC

防錯:

            Next

            Wb.Close False

            myFile = ThisWorkbook.Path & "\" & File.Name

            If Dir(myFile) <> "" Then Kill myFile

        End If

    Next