198188

回復 10# Hsieh

結果.rar (198.35 KB)

下載次數: 2

2012-11-13 15:21

可以將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

回復 10# Hsieh


    未命名.rar (118.82 KB)

下載次數: 4

2012-11-13 18:18

還是有錯誤

Hsieh

回復 11# 198188

1. Sub nn()
   
2. Dim Ay(), Rng As Range, m$, A As Range, r&, Ar
   
3. With Sheets("Sheet1") '改成正確工作表名稱
   
4. If Application.CountIf(.Range("B:B"), "JPM") > 0 Then '判斷B欄是否有JPM
   
5. .Range("B:B").Replace "JPM", "=1/0", xlWhole '將JPM以公式取代
   
6. Set Rng = .Range("B:B").SpecialCells(xlCellTypeFormulas, 16) '將公式為錯誤值的儲存格設為變數
   
7. Rng.Value = "JPM" '將公式還原成JPM
   
8. For Each A In Rng
   
9. r = A.Row
   
10. m = .Cells(r, "U") & "、" & .Cells(r, "V") & "、" & .Cells(r, "W")
    
11. 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, _
    
12. .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)
    
13. ReDim Preserve Ay(s)
    
14. Ay(s) = Ar
    
15. s = s + 1
    
16. Next
    
17. Sheets("JPM").UsedRange.Offset(1).Clear '將JPM工作表內容清空
    
18. If s > 0 Then Sheets("JPM").[A2].Resize(s, UBound(Ar) + 1) = Application.Transpose(Application.Transpose(Ay)) '將陣列寫到JPM工作表
    
19. End If
    
20. End With
    
21. End Sub

複製代碼

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

198188

回復 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

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

198188

回復 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

回復  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

回復 15# Hsieh


Outstanding Payments.rar (680.06 KB)

下載次數: 6

2012-11-13 21:28

HK ETA update.rar (360 KB)

下載次數: 5

2012-11-13 21:28

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

198188

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

    Docs Record (Update11-10).rar (102.48 KB)

下載次數: 4

2012-11-13 21:36

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

Hsieh

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

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

複製代碼