با سلام
فایل پیوست با VB تهیه گردید
کد PHP:
Sub TEST()
Dim ZZZ1, ZZZ2, X1, Y1, Z1 As Long
T1 = Sheet1.Cells(Sheet1.Rows.Count, "A").End(xlUp).Row
T2 = Sheet2.Cells(Sheet2.Rows.Count, "A").End(xlUp).Row
TB3 = Sheet3.Cells(Sheet3.Rows.Count, "B").End(xlUp).Row
tf3 = Sheet3.Cells(Sheet3.Rows.Count, "f").End(xlUp).Row
If TB3 <= 3 Then
TB3 = 4
End If
Sheet3.Range("B4:j" & TB3).ClearContents
X = Sheet3.Range("N2").Value
X1 = Left(X, 2) & Mid(X, 4, 2) & Right(X, 2)
Y = Sheet3.Range("N3").Value
Y1 = Left(Y, 2) & Mid(Y, 4, 2) & Right(Y, 2)
'============================='
If Y1 - X1 < 0 Then
MsgBox "ÊÇÑíÎ ÔÑæÚ æ ÇíÇä ÇÔÊÈÇå ÇÓÊ"
GoTo 0
End If
'===================================='
K = 4
For I = 2 To T1
Z = Sheet1.Range("A" & I)
Z1 = Left(Z, 2) & Mid(Z, 4, 2) & Right(Z, 2)
If Z1 >= X1 And Z1 <= Y1 And Sheet1.Range("C" & I).Value <> "" Then
Sheet3.Range("B" & K).Value = Sheet1.Range("A" & I).Value
Sheet3.Range("C" & K).Value = Sheet1.Range("C" & I).Value
K = K + 1
End If
Next
'==========ÇäÊåÇí ˜ åÇí ÏÑíÇÝÊí ================='
'======================ÇÞÓÇØ ÏÑíÇÝÊí ==================='
For I = 2 To T1
Z = Sheet1.Range("A" & I)
Z1 = Left(Z, 2) & Mid(Z, 4, 2) & Right(Z, 2)
If Z1 >= X1 And Z1 <= Y1 And Sheet1.Range("D" & I).Value <> "" Then
Sheet3.Range("B" & K).Value = Sheet1.Range("A" & I).Value
Sheet3.Range("D" & K).Value = Sheet1.Range("D" & I).Value
K = K + 1
End If
Next
'====================ÇäÊåÇí ÇÞÓÇØ ÏÑíÇÝÊí==================='
'=================== ÏÑÂãÏ ÂÊí==============='
K = 4
For I = 2 To T1
Z = Sheet1.Range("A" & I)
Z1 = Left(Z, 2) & Mid(Z, 4, 2) & Right(Z, 2)
If Z1 >= X1 And Z1 <= Y1 And Sheet1.Range("H" & I).Value <> "" Then
Sheet3.Range("B" & K).Value = Sheet1.Range("A" & I).Value
Sheet3.Range("E" & K).Value = Sheet1.Range("H" & I).Value
K = K + 1
End If
Next
'=================== ÇäÊåÇí ÏÑ ÂãÏ==============='
'============ÔíÊ Ïæã============'
K = 4
For I = 2 To T2
ZZZ1 = Sheet2.Range("A" & I).Value
ZZZ2 = Left(ZZZ1, 2) & Mid(ZZZ1, 4, 2) & Right(ZZZ1, 2)
If ZZZ2 >= X1 And ZZZ2 <= Y1 Then
For j = 7 To 11
If Sheet2.Range("h" & I).Value = Sheet3.Cells(3, j).Value Then
Sheet3.Range("f" & K).Value = Sheet2.Range("A" & I).Value
Sheet3.Cells(K, j).Value = Sheet2.Range("d" & I).Value
K = K + 1
End If
Next
End If
Next
'==============ÇäÊåÇí ÔíÊ Ïæã================'
Application.ScreenUpdating = True
0
End Sub
علاقه مندی ها (Bookmarks)