Sub 條件資料庫A()
Application.Run "條件資料庫A1"
Application.Run "條件資料庫A2"
Application.Run "條件資料庫A3"
Sheet3.[a2:f65536].ClearContents
X = Sheet1.[A65536].End(xlUp).Row
Y = Sheet3.[A65536].End(xlUp).Row
For M = 2 To X
If Sheet1.Cells(M, 9) = 0 Then
Sheet3.Cells(Y + 1, 1).Resize(, 6).Value = Sheet1.Cells(M, 1).Resize(, 6).Value
Y = Y + 1
End If
Next
End Sub
Sub 條件資料庫A1()
Sheet1.[G2:G65536].ClearContents
X = Sheet1.[A65536].End(xlUp).Row
For M = 2 To X
Sheet1.Cells(M, 7) = Mid(Sheet1.Cells(M, 1), 1, 7)
Next
End Sub
Sub 條件資料庫A2()
Sheet1.[H2:H65536].ClearContents
X = Sheet1.[A65536].End(xlUp).Row
For M = 2 To X
If Sheet1.Cells(M, 5) = "NULL" Or Sheet1.Cells(M, 5) = "" Or Sheet1.Cells(M, 5) = " " Then
Sheet1.Cells(M, 8) = Sheet1.Cells(M, 7)
End If
Next
End Sub
Sub 條件資料庫A3()
Sheet1.Select
Range("A1").Select
Sheet1.[I2:I65536].ClearContents
X = Sheet1.[A65536].End(xlUp).Row
For M = 2 To X
Sheet1.Cells(M, 9) = Application.CountIf(Sheet1.Range("H:H"), Sheet1.Cells(M, 7))
Next
End Sub作者: Hsieh 時間: 2017-9-27 16:39
Sub 條件資料庫A4()
Dim A As Range
Set d = CreateObject("Scripting.Dictionary")
With Sheets(1)
For Each A In .Range(.[A1], .[A1].End(xlDown))
If d(Left(A, 7)) = "" Then
d(Left(A, 7)) = Join(Application.Transpose(Application.Transpose(A.Resize(, 5))), ";")
Else
d(Left(A, 7)) = d(Left(A, 7)) & Chr(10) & Join(Application.Transpose(Application.Transpose(A.Resize(, 5))), ";")
End If
Next
For Each ky In d.keys
ar = Split(d(ky), Chr(10))
For Each c In ar
If Split(c, ";")(4) = "" Then d.Remove ky
Next
Next
'On Error Resume Next
For Each ky In d.keys
ar = Split(d(ky), Chr(10))
For Each c In ar
ay = Split(c, ";")
ay(3) = CDate(ay(3))
ay(4) = CDate(ay(4))
Sheets(2).Cells(r + 1, 1).Resize(, 5) = ay
r = r + 1
Next
Next
End With
End Sub作者: rouber590324 時間: 2017-9-28 09:45
