t591nm

回復 9# 准提部林


在匯入其他的excel檔執行後發現
.Select: .UsedRange.Clear: .[A1].Resize(Jm + 11, Km) = Arr   
紅色字體部分出現錯誤
執行階段錯誤'1004'
請問是什麼問題呢

謝謝

准提部林

回復 11# t591nm

上傳範例檔如果可以正常執行, 其它檔就要去比對其差異, 才知道錯在哪?
資料必須是有固定規則的：
第１～１１列，為〔表首〕   
第１２列，為〔標題列〕
第１３～１８列，為〔標註或備註〕吧（猜）
第１９列及以下，為〔資料明細區〕

因指定〔標題列〕符合文字才取出該欄，
所以取出資料由１９列改由１２列開始，
若要取５０筆〔明細〕，則包含〔標題〕之間的７列，Jm = TX + 7　才夠

TT = "_FL_C0_C0/C1_RLD2_RR_TS_C1_FDLD_DLD2_"
For j = 3 To UBound(Brr, 2)
    If InStr(TT, "_" & Brr(1, j) & "_") = 0 Then Brr(1, j) = ""
Next
↑這段用來排除〔標題列〕不符合文字時，使其文字變為空字符""，以為下方取得符合〔欄〕資料的依據　


請注意匯入文字檔及貼入資料的問題，
有沒考慮過為何資料會有６５５３６列，而其中有很多的〔#N/A〕錯誤值？
copy1 = Sheets(1).Range("A1:Q8000")　這才８０００列
Range("A1:Q65535") = copy1　卻貼成６５５３６列？？？？

t591nm

回復 12# 准提部林


原來如此
感謝版大幫忙
目前測試後發現絕大多數都沒問題
我再試試

關於65535的部分
已經修改為一致的列數
至於為何設那麼多
是因為每次量測顆數不一定
故才設定多一點的列數

感謝大大

t591nm

回復 12# 准提部林

已經知道為什麼有些檔案測試時 .[A1].Resize(Jm + 11, Km) = Arr 會出現錯誤
因為檔案中的格式不一致
如同版主所提到的：
第１～１１列，為〔表首〕   
第１２列，為〔標題列〕
第１３～１８列，為〔標註或備註〕吧
第１９列及以下，為〔資料明細區〕
但我每個檔案的標題列不見得在第12列
因為第13~18列中有時後會為了備註其他資訊
所以第一筆測試數值不見得會在第19列

故我想判斷符合文字的部分要從第一列開始
依據目前工作表的作用範圍的欄來進行逐一的判斷
不知道我這樣的邏輯對不對

准提部林

Sub vbaAFilter()
Dim j&, Jm&, k&, Km&, TX&, Arr, Brr, N&, uChk&, TT$, Sht As Worksheet
TX = TextBox1.Text: If TX = 0 Then Exit Sub
Arr = Sheets("工作表1").UsedRange.Value
ReDim Brr(1 To UBound(Arr, 2))
TT = "_FL_C0_C0/C1_RLD2_RR_TS_C1_FDLD_DLD2_"
　
For j = 1 To UBound(Arr)
　　If Arr(j, 1) = "Crystal" Then　'以〔Crystal〕判斷是否為〔標題列〕　
　　　For k = 1 To UBound(Arr, 2)
　　　　　Brr(k) = Arr(j, k)　'標題文字納入陣列，不符合者填入空字符　
　　　　　If k > 2 And InStr(TT, "_" & Arr(j, k) & "_") = 0 Then Brr(k) = ""
　　　Next k
　　　uChk = 1: 　N = j - 1　'標題列上方的〔列數〕　
　　End If
　
　　If Arr(j, 1) = 1 Then uChk = 2: N = j - 1: Jm = 0　
　　'＿若Ａ欄為１，則判斷為〔明細〕的開始，Ｎ為上方列數，Jm歸零　
　　If uChk = 0 Then GoTo 101
　　If uChk = 2 And Arr(j, 2) <> "PASS" Then GoTo 101
　　Jm = Jm + 1: Km = 0
　　For k = 1 To UBound(Arr, 2)
　　　　If Brr(k) <> "" Then Km = Km + 1: Arr(Jm + N, Km) = Arr(j, k)
　　Next
　
　　If uChk = 2 And Jm = TX Then Exit For
101: Next j
If Jm = 0 Then Exit Sub
　
On Error Resume Next: Set Sht = Sheets("PASS名單"): On Error GoTo 0
If Sht Is Nothing Then Set Sht = Sheets.Add:  Sht.Name = "PASS名單"
With Sht
　　.Select: .UsedRange.Clear: .[A1].Resize(Jm + N, Km) = Arr
End With
End Sub

'＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝
uChk =1 表示迴圈到〔標題列〕
uChk =2 表示迴圈到〔明細〕的開頭

資料底下的〔錯誤值〕務必先清除～～　

准提部林

回復 14# t591nm


是可以將〔標題列〕及〔明細開頭〕強制固定列號，
若有不同，可手動調整，只要多保留幾個空白列當緩衝即可～～辦法是想出來的～～

t591nm

回復 15# 准提部林


太感謝版主了
剛也想以Crystal做為標題列的判斷
只是還沒run出來

我是這樣寫
TT2 = "Crystal"
For j2 = 1 To UBound(Brr, 1)
If InStr(TT2, "_" & Brr(1, j) & "_") = 0 Then
只是錯在If InStr(TT2, "_" & Brr(1, j) & "_") = 0 Then 這一行
我先試試版大的辦法

t591nm

回復 16# 准提部林

感謝版主
測試成功
讓我學習到很多細節
謝謝

t591nm

回復 17# t591nm

版主不好意思
我又有個笨問題了
Private Sub CommandButton1_Click()
fileToOpen = Dir(Application.GetOpenFilename("Excel File(*.xls),*.xls"))
a = Split(fileToOpen, "/")
b = a(UBound(a))
MsgBox Left(b, InStr(b, ".") - 1)
End Sub
以上是我run過確定可以執行的程式碼

Private Sub CommandButton4_Click()
    Dim Arr3 As Variant

    Arr3 = Array("PASS名單", "DATA")
    Sheets(Arr3).Copy
    Arr3 = Application.GetSaveAsFilename(fileFilter:="*.xls, *.xls")
End Sub
以上程式碼中我就有問題了
我想讓CommandButton1_Click()中的b可以被CommandButton4_Click()來使用
由於觀念不清楚所以不知道怎麼引用
我所要的是另存新檔時檔名為該筆所匯入的檔名且不含副檔名
本來想說在CommandButton1_Click()中已經可以run出來要的檔名了
卻沒想到後期無法直接引用...
而且還有一個問題...可能是因為另存新檔中有兩個工作表...所以要按兩次存檔才可以
以上不知道如何排解
感謝大大

t591nm

已解決

Private Sub CommandButton4_Click()
   Dim nm As String, FileFolder As String
   nm = Sheets("DATA").Range("G1").Value
   Arr3 = Array("PASS名單", "DATA")
   Sheets(Arr3).Copy
   FileFolder = Application.GetSaveAsFilename(nm & "-", "(*.xls),*.xls")
   Sheets("DATA").Range("G1").Clear
   Sheets("PASS名單").Range("G1").Clear
   ActiveWorkbook.SaveAs FileFolder
End Sub

這樣就可以達到我要的目的了