如何可以讓不是"JPM"不顯示出來，也不會留一行空格？

198188

Book1.rar (10.67 KB)

下載次數: 17

2012-11-11 02:39

Sub JPM()
   Dim i As Integer, j As Integer, k As Integer, l As Integer
   Dim rowC As Integer
   Dim rB As Range
   Dim data() As String
   Dim found As Boolean

   '先將 AK:AR 的資料清除
   Worksheets("jpm").[A2:O65536].ClearContents

   '計算多少筆資料要處理
   rowC = Sheets(1).Range("A1").CurrentRegion.Rows.Count
   '先暫存資料，加速處理
   Set rB = Sheets(1).Range(Cells(1, 1), Cells(rowC, 32))
   ReDim data(rowC, 32)

   k = 0
   For i = 1 To rowC '處理資料
       j = 1
       found = False
       While (j <= k) And (found = False) '比對有沒有出現過
          If rB(i, 19) = data(j, 19) And rB(i, 20) = data(j, 20) And rB(i, 3) = data(j, 3) Then
             found = True
             data(j, 3) = rB(i, 3)
             data(j, 4) = rB(i, 4)
             data(j, 6) = rB(i, 6)
             data(j, 19) = rB(i, 19) + "、" + rB(i, 19)
             data(j, 20) = rB(i, 20) + "、" + rB(i, 20)
             data(j, 21) = data(j, 21) + "、" + rB(i, 21)
             data(j, 22) = data(j, 22) + "、" + rB(i, 22)
             data(j, 23) = data(j, 23) + "、" + rB(i, 23)
             data(j, 24) = data(j, 24) + "、" + rB(i, 24)
             data(j, 25) = data(j, 25) + "、" + rB(i, 25)
             data(j, 26) = data(j, 26) + "、" + rB(i, 26)
             data(j, 27) = rB(i, 27)
             data(j, 28) = rB(i, 28)
             data(j, 29) = rB(i, 29)
             data(j, 30) = rB(i, 30)
             data(j, 31) = rB(i, 31)
             data(j, 32) = rB(i, 32)
        End If
          j = j + 1
       Wend

       If found = False Then  '沒有出現過加入新資料
          k = k + 1
          data(k, 3) = rB(i, 3)
          data(k, 4) = rB(i, 4)
          data(k, 6) = rB(i, 6)
          data(k, 19) = rB(i, 19)
          data(k, 20) = rB(i, 20)
          data(k, 21) = rB(i, 21)
          data(k, 22) = rB(i, 22)
          data(k, 23) = rB(i, 23)
          data(k, 24) = rB(i, 24)
          data(k, 25) = rB(i, 25)
          data(k, 26) = rB(i, 26)
          data(k, 27) = rB(i, 27)
          data(k, 28) = rB(i, 28)
          data(k, 29) = rB(i, 29)
          data(k, 30) = rB(i, 30)
          data(k, 31) = rB(i, 31)
          data(k, 32) = rB(i, 32)
     End If
   Next i

       l = 1
   For i = 1 To k '列印資料
      
       If Range("B" & i + 1).Value = "JPM" Then
      
       Sheets("JPM").Cells(l, 1) = data(i, 19)
       Sheets("JPM").Cells(l, 2) = data(i, 20)
       Sheets("JPM").Cells(l, 3) = data(i, 3)
       Sheets("JPM").Cells(l, 4) = data(i, 27)
       Sheets("JPM").Cells(l, 5) = data(i, 4)
       Sheets("JPM").Cells(l, 6) = data(i, 28)
       Sheets("JPM").Cells(l, 7) = data(i, 29)
       Sheets("JPM").Cells(l, 8) = data(i, 30)
       Sheets("JPM").Cells(l, 9) = data(i, 31)
       Sheets("JPM").Cells(l, 10) = data(i, 32)
       Sheets("JPM").Cells(l, 11) = data(i, 6)
       Sheets("JPM").Cells(l, 12) = data(i, 21) + "、" + data(i, 22) + "、" + data(i, 23)
       Sheets("JPM").Cells(l, 13) = data(i, 24)
       Sheets("JPM").Cells(l, 14) = data(i, 25)
       Sheets("JPM").Cells(l, 15) = data(i, 26)
       End If
       l = l + 1
      Next i

MsgBox ("Sucess")

End Sub

如何可以讓不是"JPM"不顯示出來，也不會留一行空格？

Hsieh

回復 1# 198188


    進階篩選即可

198188

回復 2# Hsieh

vba 沒有辦法讓它不出現嗎？

Hsieh

回復 3# 198188


    你是要把JPM的資料列複製過去不是嗎?
那就錄製進階篩選取得程式碼就好了
若不想多出準則欄位，那用以下代碼
將JPM用錯誤值公式取代
然後複製這些列貼到目標位置

1. Sub nn()
   
2. With 工作表1
   
3. .Range("B:B").Replace "JPM", "=1/0", xlWhole
   
4. Set Rng = .Range("B:B").SpecialCells(xlCellTypeFormulas, 16)
   
5. Rng.Value = "JPM"
   
6. Rng.EntireRow.Copy Sheets("JPM").[A2]
   
7. End With
   
8. End Sub

複製代碼

c_c_lai

回復 1# 198188
不知道這是否是你的需求？

1. Sub Test()
   
2.     Sheets("JPM").Visible = False
   
3. End Sub
   
4. 
   
5. Sub Test2()
   
6.     Sheets("JPM").Visible = True
   
7. End Sub

複製代碼

198188

回復 4# Hsieh


    04.Set Rng = .Range("B:B").SpecialCells(xlCellTypeFormulas, 16) 出現error, 將我DATA BASE的 JPM轉成1/0,但在jpm worksheet內就沒有copy 資料過去！

另外JPM  worksheet的資料是順序將DATA BASE的 JPM資料抄過來，但擺位是不一樣

DATA BASE (SHEET1)
欄數由A :Z
ITEM NO / STATE / SO / BUYER / AGENT / ETA /RECEIVE DATE/ RECEIVE TRACKING NO/ RECEIVE OBL/RECEIVE OHC/RECEIVE OTHER DOCS/RECEIVE REMARK/SEND DATE/SEND TRACKING NO/ SEND OBL/SEND OHC/SEND OTHER DOCS/SEND REMARK/ JPM DATE/JPM REF NO/JPM OBL/JPM OHC/ JPM OTHER DOCS/JPM REMARK/JPM US ARRANGE PAYMENT ON/JPM HK PICK UP ON

JPM WORKSHEET (JPM)只顯示這些資料
欄數由A : G
JPM DATE / JPM REF NO / SO/JPM DOCS LIST(JPM OBL, JPM OHC, JPM OTHER DOCS 合併）/JPM REMARK/JPM US ARRANGE PAYMENT ON/JPM HK PICK UP ON

198188

回復 5# c_c_lai


    這個程式沒有反映，是否還欠缺一些資料？

Hsieh

回復 6# 198188

1. Sub nn()
   
2. With 工作表1
   
3. If Application.CountIf(.Range("B:B"), "JPM") > 0 Then '判斷B欄是否有JPM
   
4. .Range("B:B").Replace "JPM", "=1/0", xlWhole '將JPM以公式取代
   
5. Set Rng = .Range("B:B").SpecialCells(xlCellTypeFormulas, 16) '將公式為錯誤值的儲存格設為變數
   
6. Rng.Value = "JPM" '將公式還原成JPM
   
7. Sheets("JPM").UsedRange.Offset(1).Clear '將JPM工作表內容清空
   
8. Rng.EntireRow.Copy Sheets("JPM").[A2] '將B欄為JPM的列複製貼到JPM工作表
   
9. End If
   
10. End With
    
11. End Sub

複製代碼

198188

回復 8# Hsieh


result.rar (486.07 KB)

下載次數: 4

2012-11-13 14:36

還是沒有顯示出來. JPM WORKSHEET空白一片~
另外想問
Sub sample()

Dim LastRec As Integer
Dim j As Integer
Dim i As Integer
Dim l As Integer
Dim data() As Range
l = 1

Worksheets("Sheet1").Range("A1").Select
ActiveCell.End(xlDown).Select
     LastRec = ActiveCell.Row
     

For j = 1 To LastRec

i = Application.Match(Sheet1.Cells(1, j), "C:\user\destop\[outstanding payment]Sheet2'!.Range("A:A"), 0) 我想讀取桌面另外一個excel的資料，這句是不是有問題？

If Sheet1.Cells(i, 2).Value <> Sheet2.Cells(i, 2).Value Then

Sheet1.Cells(i, 2).Value = Sheet2.Cells(i, 2).Value
Sheet1.Cells(i, 2).Interior.Color = RGB(255, 200, 255)
End If

Next j

End Sub

Hsieh

回復 9# 198188

1. Sub nn()
   
2. With Sheets("Sheet1") '改成正確工作表名稱
   
3. If Application.CountIf(.Range("B:B"), "JPM") > 0 Then '判斷B欄是否有JPM
   
4. .Range("B:B").Replace "JPM", "=1/0", xlWhole '將JPM以公式取代
   
5. Set Rng = .Range("B:B").SpecialCells(xlCellTypeFormulas, 16) '將公式為錯誤值的儲存格設為變數
   
6. Rng.Value = "JPM" '將公式還原成JPM
   
7. Sheets("JPM").UsedRange.Offset(1).Clear '將JPM工作表內容清空
   
8. Rng.EntireRow.Copy Sheets("JPM").[A2] '將B欄為JPM的列複製貼到JPM工作表
   
9. End If
   
10. End With
    
11. End Sub

複製代碼

問題二
開啟檔案
fs = "C:\user\destop\outstanding payment.xlsx"
Set wb = Workbooks.Open(fs)
For j=1 To ....
i = Application.Match(Sheet1.Cells(1, j), wb.Sheets("Sheet2").[A:A], 0)
...
...
...
Next
wb.Close 0