With ActiveSheet
If .AutoFilterMode Then .AutoFilterMode = False
If .FilterMode Then .ShowAllData
End With
sq = Sheets("11").Cells(3, 2)
Worksheets("AA").Select
Worksheets("AA").Range("A1:F56").ClearContents
sqlstr = sq
resultArr = VBADataXfer.GetSQLResult("XXX", sqlstr, True, "XXXX")
Call xferToWorksheet(resultArr, "AA", "A1")
' Cells.WrapText = False
Worksheets("AA").Select
With ActiveSheet
If .AutoFilterMode Then .AutoFilterMode = False
If .FilterMode Then .ShowAllData
End With
sq = Sheets("11").Cells(4, 2)
Worksheets("BB").Select
Worksheets("BB").Range("A1:F51").ClearContents
sqlstr = sq
resultArr = VBADataXfer.GetSQLResult("XXX", sqlstr, True, "XXXX")
Call xferToWorksheet(resultArr, "BB", "A1")
' Cells.WrapText = False
Worksheets("AA").Select
End Sub
下面是欲最後執行的巨集
Sub 匯出()
記錄 ActiveSheet.Shapes(Application.Caller).TextFrame.Characters.Text, [CCC!L3]
Dim xR As Range, XSHT As Worksheet, xArea As Range
Dim uFile$, uBook As Workbook, uSht As Worksheet, uPath$
Dim T1$, T2$, T3$, i&
uPath = ThisWorkbook.Path
If [F4] <> "" Then uPath = [F4]
If Right(uPath, 1) <> "\" Then uPath = uPath & "\"
If Dir(uPath, vbDirectory) = "" Then MsgBox "找不到指定路徑！": Exit Sub
Application.ScreenUpdating = False
On Error Resume Next
For Each xR In Range([B2], [B65536].End(xlUp))
T1 = xR: T2 = xR(1, 2): T3 = xR(1, 3)
If xR.Row < 2 Or T1 = "" Or T2 = "" Or T3 = "" Then GoTo 101
Set XSHT = Nothing: Set XSHT = ThisWorkbook.Sheets(T1)
If XSHT Is Nothing Then xR(1, 4) = "找不到：" & T1: GoTo 101
uFile = uPath & T2
If Dir(uFile) = "" Then xR(1, 4) = "找不到：" & T2: GoTo 101
Set uBook = Nothing: Set uBook = Workbooks(T2)
If uBook Is Nothing Then Set uBook = Workbooks.Open(uFile)
Set uSht = Nothing: Set uSht = uBook.Sheets(T3)
If uSht Is Nothing Then xR(1, 4) = "找不到：" & T3: uBook.Close: GoTo 101
uSht.Activate
uSht.Unprotect "111" '解除工作表保護(密碼自行加入)
uSht.UsedRange.Clear
Set xArea = XSHT.UsedRange: xArea.Copy
With uSht.Range(xArea.Address)
.PasteSpecial xlPasteFormats
.PasteSpecial xlPasteValues
.Replace "", "^^^", Lookat:=xlWhole
.Replace "^^^", "", Lookat:=xlWhole
.Columns(2).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End With
uSht.Protect "111" '恢復工作表保護(密碼自行加入)
Application.CutCopyMode = False
uBook.Close SaveChanges:=True
xR(1, 4) = "＜匯出完成＞"
101: Next
On Error GoTo 0
[F2] = Now: Beep '記錄匯出日期及時間，發出beep聲提示結束
MsgBox "匯出ok！"
End Sub 作者: RCRG 時間: 2019-1-29 17:31
