麻辣家族討論版版 - Powered by Discuz! Board

標題: 如何可以讓不是"JPM"不顯示出來，也不會留一行空格？ [打印本頁]

作者: 198188 時間: 2012-11-11 02:41 標題: 如何可以讓不是"JPM"不顯示出來，也不會留一行空格？

[attach]13093[/attach]
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 時間: 2012-11-12 14:52

回復 1# 198188

進階篩選即可

作者: 198188 時間: 2012-11-12 15:05

回復 2# Hsieh

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

作者: Hsieh 時間: 2012-11-12 15:13

回復 3# 198188

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

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

複製代碼

作者: c_c_lai 時間: 2012-11-13 07:52

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

Sub Test()
Sheets("JPM").Visible = False
End Sub
Sub Test2()
Sheets("JPM").Visible = True
End Sub

複製代碼

作者: 198188 時間: 2012-11-13 10:19

回復 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 時間: 2012-11-13 10:20

回復 5# c_c_lai

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

作者: Hsieh 時間: 2012-11-13 14:10

回復 6# 198188

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

複製代碼

作者: 198188 時間: 2012-11-13 14:41

回復 8# Hsieh

[attach]13111[/attach]

還是沒有顯示出來. 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 時間: 2012-11-13 15:12

本帖最後由 Hsieh 於 2012-11-13 15:13 編輯

回復 9# 198188

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

作者: 198188 時間: 2012-11-13 15:24

回復 10# Hsieh

[attach]13113[/attach]

可以將JPM 資料複製過去了，謝謝！
但是有沒有方法改變它們的位置，因為我不是要全部搬過去，和我想它們在A:F順序抄過去。

DATE TRACKING NO SO NO MM BUYER PLANT BOXES CONTAINER NO ORIGIN ETD ETA DOCS LIST REMARK US ARRANGE PAYMENT ON HK PICK UP ON

作者: 198188 時間: 2012-11-13 18:18

回復 10# Hsieh

[attach]13121[/attach]
還是有錯誤

作者: Hsieh 時間: 2012-11-13 20:27

回復 11# 198188

Sub nn()
Dim Ay(), Rng As Range, m$, A As Range, r&, Ar
With Sheets("Sheet1") '改成正確工作表名稱
If Application.CountIf(.Range("B:B"), "JPM") > 0 Then '判斷B欄是否有JPM
.Range("B:B").Replace "JPM", "=1/0", xlWhole '將JPM以公式取代
Set Rng = .Range("B:B").SpecialCells(xlCellTypeFormulas, 16) '將公式為錯誤值的儲存格設為變數
Rng.Value = "JPM" '將公式還原成JPM
For Each A In Rng
r = A.Row
m = .Cells(r, "U") & "、" & .Cells(r, "V") & "、" & .Cells(r, "W")
Ar = Array(.Cells(r, "S").Value, .Cells(r, "T").Value, .Cells(r, "C").Value, .Cells(r, "AA").Value, .Cells(r, "D").Value, .Cells(r, "AB").Value, _
.Cells(r, "AC").Value, .Cells(r, "AD").Value, .Cells(r, "AE").Value, .Cells(r, "AF").Value, .Cells(r, "F").Value, m, .Cells(r, "X").Value, .Cells(r, "Y").Value, .Cells(r, "Z").Value)
ReDim Preserve Ay(s)
Ay(s) = Ar
s = s + 1
Next
Sheets("JPM").UsedRange.Offset(1).Clear '將JPM工作表內容清空
If s > 0 Then Sheets("JPM").[A2].Resize(s, UBound(Ar) + 1) = Application.Transpose(Application.Transpose(Ay)) '將陣列寫到JPM工作表
End If
End With
End Sub

複製代碼

Match函數如果找不到符合資料就會出錯

作者: 198188 時間: 2012-11-13 20:35

回復 10# Hsieh

Sub sample()

Dim LastRec As Integer
Dim j As Integer
Dim i As Integer
Dim l As Integer
Dim data() As Range
l = 1
fs = "C:\Documents and Settings\USER\桌面\HK ETA update.xlsx"       這句出現error 執行階段錯誤'13'型態不符合！
Set wb = Workbooks.Open(fs)

Workbooks("outstanding payments").Worksheets("2012").Range("A1").Select 這
ActiveCell.End(xlDown).Select
   LastRec = ActiveCell.Row


For j = 1 To LastRec

i = Application.Match(Worksheets("2012").Cells(j, 1), wb.Sheets("香港&海防單").Range("A:A"), 0)

If Worksheets("2012").Cells(i, 4).Value <> wb.Sheets("香港&海防單").Cells(i, 12).Value Then

Worksheets("2012").Cells(i, 4).Value = wb.Sheets("香港&海防單").Cells(i, 2).Value
Worksheets("2012").Cells(i, 4).Interior.Color = RGB(255, 200, 255)
End If

Next j

wb.Close 0

End Sub

作者: Hsieh 時間: 2012-11-13 20:45

回復 14# 198188
瞎子摸象
fs寫入字串不可能出錯，就算是路徑錯誤也不是在該行出錯
請把問題說明清楚，否則問題不再回復

作者: 198188 時間: 2012-11-13 21:07

回復 13# Hsieh

可以了！謝謝！
11/11/2012
12/11/2012
13/11/2012
15/11/2012
15/11/2012
18/11/2012
19/11/2012
11/11/2012
11/11/2012
11/11/2012

11/11/2012
11/12/2012
13/11/2012
15/11/2012
15/11/2012
18/11/2012
19/11/2012
11/11/2012
11/11/2012
11/11/2012
但是我想問，為何第二個的日期會變成11/12/2012?是哪裡出現問題？是不是因為我設定輸入時在日期前加'才這樣？但也只有一個出錯，不是全部出錯！
是不是資料庫內沒有JPM的資料就會出現問題？那是不是可以加句，如果沒有JPM的資料就不執行這個程式,那樣就沒事了？

作者: 198188 時間: 2012-11-13 21:21

回復 Hsieh

可以了！謝謝！
11/11/2012
12/11/2012
13/11/2012
15/11/2012
15/11/2012
18 ...
198188 發表於 2012-11-13 21:07

另外我想再問一樣！
RECEIVE
SEND
各有資料，但可否兩個STATE自我檢查，例如：
RECEIVE有以下資料
207626 / XIANG / CHEONG / 23-OCT-12 / 15/11/2012 / DHL200 / OBL /          /          /PM
207626 / XIANG / CHEONG / 23-OCT-12 / 18/11/2012 / DHL201 /       / OHC  /          /AM
207626 / XIANG / CHEONG / 23-OCT-12 / 19/11/2012 / DHL202/    /          / CO  /AM

SEND 有以下資料
207626 / XIANG / CHEONG / 23-OCT-12 / 19/11/2012 / SF111 /       / OHC  /    /AM

然後電腦會自動記算還有哪些在手上還沒寄出！

207626 / XIANG / CHEONG / 23-OCT-12 / 15/11/2012,19/11/2012  / DHL200,DHL202 / OBL,CO  /  PM,AM

作者: 198188 時間: 2012-11-13 21:29

回復 15# Hsieh

[attach]13122[/attach][attach]13123[/attach]

隨上附件！麻煩請看看！感激不盡~

作者: 198188 時間: 2012-11-13 21:41

另外我想再問一樣！
RECEIVE
SEND
各有資料，但可否兩個STATE自我檢查，例如：
RECEIVE有以 ...
198188 發表於 2012-11-13 21:21

[attach]13124[/attach]
vba可以做到一個excel讓多位用家同時使用，輸入、儲存？
如果不能的話，vba可否用四個excel讓用家使用，然後再將這四個excel的資料定時傳到附件總表,然後再運算?

作者: Hsieh 時間: 2012-11-14 10:42

回復 18# 198188
提問時請描述你的需求
光從你的程式碼去猜你的需求會造成很大的差異
看看是否合乎你的需求

Sub sample()
Dim FRng As Range
Dim A As Range, Rng As Range
fs = "C:\Documents and Settings\USER\桌面\HK ETA update.xlsx"
'fs = ThisWorkbook.Path & "\HK ETA update.xlsx"'同一目錄時使用
Set wb = Workbooks.Open(fs)
With ThisWorkbook.Worksheets("2012")
For Each A In .Range(.[A2], .Range("A1").End(xlDown))
Set FRng = wb.Sheets("香港&海防單").Range("A:A").Find(A, lookat:=xlWhole)
If Not FRng Is Nothing Then
If FRng.Offset(, 11) <> A.Offset(, 3) Then
A.Offset(, 3) = FRng.Offset(, 11).Value '讓2012的D欄等於香港&海防單的L欄
If Rng Is Nothing Then Set Rng = A.Offset(, 3) Else Set Rng = Union(Rng, A.Offset(, 3))
End If
End If
Set FRng = Nothing
Next
If Not Rng Is Nothing Then Rng.Interior.Color = RGB(255, 200, 255)
End With
wb.Close 0
End Sub

複製代碼

作者: 198188 時間: 2012-11-14 12:06

回復 20# Hsieh

可以了，謝謝您！
我主要是想在outstanding payments 表內根據HK ETA UPDATE內的資料更新，相同so,如果HK ETA UPDATE內的ETA和outstanding payments 表內的不同，就把outstanding payments 表內的ETA更改成HK ETA UPDATE內的ETA，然後標上顏色，如果相同就不變及如果outstanding payments 表內的so在HK ETA UPDATE表內沒有，也不變。

作者: 198188 時間: 2012-11-16 14:27

回復 20# Hsieh

Set FRng = wb.Sheets("香港&海防單").Range("A:A").Find(A, lookat:=xlWhole) 請問如果在A:A內有兩個相同資料，那麼如何指令它由下至上找，我想要的是最後那個。

例如：

我想找123456，而出來的答案是e,而不是b.應該怎樣改？

wb.Sheets("香港&海防單").Range("A:A")內有這些資料
123455 a
123456 b
123457 c
123458 d
123456 e

作者: 198188 時間: 2012-11-16 17:07

回復 22# 198188

各位高手，請問有沒有可以幫忙解決這個問題？
Sub HK()

Dim FRng As Range

Dim A As Range, Rng As Range
Dim i As Integer

fs = "C:\Users\patrick.HKG\Desktop\Payment\Updated info\payment report 2012.xlsx"

'fs = ThisWorkbook.Path & "\payment report 2012.xlsx"'同一目錄時使用

Set wb = Workbooks.Open(fs)

With ThisWorkbook.Worksheets("2012")

For Each A In .Range(.[A2], .Range("A1").End(xlDown))

Set FRng = wb.Sheets("New form of payment report").Range("A:A").Find(A, lookat:=xlWhole) 這句只是由A1開始順序找尋下去，得出答案是第一個相同的資料。請問有無方法將它改成由A65536 開始順序找尋上去，得出答案是最後相同的資料
If Not FRng Is Nothing Then

   If FRng.Offset(, 6).Value > 0.95 Then

      A.Offset(, 5) = FRng.Offset(, 9).Value '讓2012的D欄等於香港&海防單的L欄

      If Rng Is Nothing Then Set Rng = A.Offset(, 5) Else Set Rng = Union(Rng, A.Offset(, 5))

   End If

End If

   Set FRng = Nothing

Next

End With

wb.Close 0

End Sub

歡迎光臨麻辣家族討論版版 (http://forum.twbts.com/)