Sub TongHop2()
Dim Rws As Long, W As Integer, J As Long
Dim Cls As Range, sRng As Range, Rng As Range
Dim MyAdd As String
Rws = [B4].CurrentRegion.Rows.Count
For J = 3 To Rws + 1
Cells(J, "F").Value = Cells(J, "B").Value & "@" & Cells(J, "C").Value
Next J
ReDim Arr(1 To Rws, 1 To 4)
Set Rng = [F3].Resize(Rws)
[H4].Resize(Rws).Interior.ColorIndex = 0
For Each Cls In Range([H4], [H4].End(xlDown))
Set sRng = Rng.Find(Cls.Value & "@" & Cls.Offset(, 1).Value, , xlFormulas, xlWhole)
If sRng Is Nothing Then
W = W + 1: Arr(W, 1) = Cls.Value
Arr(W, 2) = Cls.Offset(, 1).Value: Arr(W, 4) = Cls.Offset(, 2).Value
Else
Cls.Interior.ColorIndex = 38
End If
Next Cls
Set Rng = [B4].Resize(Rws)
For Each Cls In Range([H4], [H4].End(xlDown))
If Cls.Interior.ColorIndex = 38 Then
Set sRng = Rng.Find(Cls.Value)
If Not sRng Is Nothing Then
MyAdd = sRng.Address
Do
If sRng.Offset(, 1).Value = Cls.Offset(, 1).Value Then
sRng.Offset(, 3).Value = Cls.Offset(, 2).Value
End If
Set sRng = Rng.FindNext(sRng)
Loop While Not sRng Is Nothing And sRng.Address <> MyAdd
End If
End If
Next Cls
If W Then
[B4].End(xlDown).Offset(1).Resize(W, 4).Value = Arr()
End If
End Sub
Với dữ liệu không nhiều, chạy subchào các bác em có đề bài như file đính kèm, các bác có cách nào để tự động thêm dòng và giá trị còn thiếu từ sheet 2 vào sheets 1 không ạ?
Sub ABC()
Dim aMay(), aMay2(), Res(), sR&, sR2&, i&, r&, k&, sp$, lop$
With Sheets("Sheet1")
aMay = .Range("B4:D" & .Range("C" & Rows.Count).End(xlUp).Row).Value
aMay2 = .Range("H4:J" & .Range("H" & Rows.Count).End(xlUp).Row).Value
sR = UBound(aMay): sR2 = UBound(aMay2)
ReDim Res(1 To sR + sR2, 1 To 4)
For r = 1 To sR
Res(r, 1) = aMay(r, 1): Res(r, 2) = aMay(r, 2): Res(r, 3) = aMay(r, 3)
Next r
k = r - 1
For i = 1 To sR2
sp = aMay2(i, 1): lop = aMay2(i, 2)
For r = 1 To sR
If sp = aMay(r, 1) Then
If lop = aMay(r, 2) Then Res(r, 4) = aMay2(i, 3): Exit For
End If
Next r
If r = sR + 1 Then
k = k + 1
Res(k, 1) = aMay2(i, 1): Res(k, 2) = aMay2(i, 2): Res(k, 4) = aMay2(i, 3)
End If
Next i
.Range("N4").Resize(k, 4) = Res
.Range("N4").Resize(k, 4).Sort .[N4], 1, .[O4], , 1, Header:=xlNo
End With
End Sub
Thì thêm động tác sắp xếp & đánh lại STT; Chuyện này có thể làm bằng thủ công hay tự động đều được.. . . .. Em đã test có ra kết quả nhưng những dữ liệu bổ sung thì đi thêm vào cuối bảng ah. em muốn sắp xếp theo thứ tự SP và LOP thì nên làm như thế nào ah.
Tự động thêm dòng bất kỳ theo điều kiện
chào các bác em có đề bài như file đính kèm, các bác có cách nào để tự động thêm dòng và giá trị còn thiếu từ sheet 2 vào sheets 1 không ạ?
Sub mới tốc độ nhanh hơnCảm ơn bác Hiếu CD. Nhưng vs vài nghìn dữ liệu thì dùng hàm nào ah?
Bài đã được tự động gộp:
Cảm ơn bác SA_DQ. Em đã test có ra kết quả nhưng những dữ liệu bổ sung thì đi thêm vào cuối bảng ah. em muốn sắp xếp theo thứ tự SP và LOP thì nên làm như thế nào ah.
Sub ABC()
Dim aMay(), aMay2(), Res(), dic As Object, sR&, sR2&, i&, iR&, k&, iKey$
Set dic = CreateObject("scripting.dictionary")
With Sheets("Sheet1")
aMay = .Range("B4:D" & .Range("C" & Rows.Count).End(xlUp).Row).Value
aMay2 = .Range("H4:J" & .Range("H" & Rows.Count).End(xlUp).Row).Value
sR = UBound(aMay): sR2 = UBound(aMay2)
ReDim Res(1 To sR + sR2, 1 To 4)
For k = 1 To sR
Res(k, 1) = aMay(k, 1): Res(k, 2) = aMay(k, 2): Res(k, 3) = aMay(k, 3)
dic.Item(aMay(k, 1) & "|" & aMay(k, 2)) = k
Next k
k = k - 1
For i = 1 To sR2
iKey = aMay2(i, 1) & "|" & aMay2(i, 2)
If dic.exists(iKey) = False Then
k = k + 1
dic.Add iKey, k
Res(k, 1) = aMay2(i, 1): Res(k, 2) = aMay2(i, 2)
End If
iR = dic.Item(iKey)
Res(iR, 4) = aMay2(i, 3)
Next i
.Range("N4").Resize(k, 4) = Res
.Range("N4").Resize(k, 4).Sort .[N4], 1, .[O4], , 1, Header:=xlNo
End With
End Sub
Bác HiếuCD ơi để giải quyết được triệt để hơn em muốn hỏi thêm là: với code hiện tại giá trị trả về thì những dữ liệu trùng giữa máy 1 và máy 2 thì cột máy 2 lại k tự động điền x hay o, để thêm bước này thì nên làm như thế nào ạ?
Code tự điền dữ liệu trùng mờBác HiếuCD ơi để giải quyết được triệt để hơn em muốn hỏi thêm là: với code hiện tại giá trị trả về thì những dữ liệu trùng giữa máy 1 và máy 2 thì cột máy 2 lại k tự động điền x hay o, để thêm bước này thì nên làm như thế nào ạ?
適用 | 検索条件 | 必須条件 | 優先順位 | レジスト種別 | 解除可能 フラグ | KRF-SCN-L01 | KRF-SCN-L02 | KRF-SCN-L03 | KRF-SCN-L04 | 検索条件 | 使用 フラグ | |||||||||
品種グループID | レイヤID | レシピID | ロットID | 装置ID | レチクルID | レチクル位置 | 品種グループID | レイヤID | ||||||||||||
Y | 103SC10ERF | CNOD | * | * | * | * | 1 | L41 | Y | ○ | ○ | 103SC10ERFCNOD | 103SC10ERF | CNOD | ○ | 1 | ||||
Y | 103SC10ERF | LNOD | * | * | * | * | 1 | L41 | Y | ○ | ○ | 103SC10ERFLNOD | 103SC10ERF | LNOD | ○ | 2 | ||||
Y | 103SC10ERF | LNOD_3002 | * | * | * | * | 1 | L43 | Y | ○ | 103SC10ERFLPOD | 103SC10ERF | LPOD | ○ | 4 | |||||
Y | 103SC10ERF | LPOD | * | * | * | * | 1 | L41 | Y | ○ | ○ | 103SC10ERFMNOD | 103SC10ERF | MNOD | ○ | 5 | ||||
Y | 103SC10ERF | MNOD | * | * | * | * | 1 | L41 | Y | ○ | ○ | 103SC10ERFMPOD | 103SC10ERF | MPOD | ○ | 7 | ||||
Y | 103SC10ERF | MNOD_3002 | * | * | * | * | 1 | L43 | Y | ○ | 103SC10ERFNDOD | 103SC10ERF | NDOD | × | 8 | |||||
Y | 103SC10ERF | MPOD | * | * | * | * | 1 | L41 | Y | ○ | ○ | 103SC10ERFNFOD | 103SC10ERF | NFOD | ○ | 10 | ||||
Y | 103SC10ERF | NDOD | * | * | * | * | 1 | L41 | Y | × | ○ | 103SC10ERFNIOD | 103SC10ERF | NIOD | ○ | NG | ||||
Y | 103SC10ERF | NDOD_3002 | * | * | * | * | 1 | L43 | Y | ○ | 103SC10ERFNSOD | 103SC10ERF | NSOD | ○ | NG | |||||
Y | 103SC10ERF | NFOD | * | * | * | * | 1 | L41 | Y | ○ | ○ | 103SC10ERFPD | 103SC10ERF | PD | × | NG | ||||
Y | 103SC10ERF | NFOD_3002 | * | * | * | * | 1 | L43 | Y | ○ | 103SC10ERFPDOD | 103SC10ERF | PDOD | × | NG |
Sub TongHop_A()
Dim Rws As Long, W As Integer, J As Long
Dim Cls As Range, sRng As Range, Rng As Range
Dim MyAdd As String
Rws = [B28].CurrentRegion.Rows.Count '4 '
For J = 27 To Rws + 28 '3 - 28 '
Cells(J, "A").Value = Cells(J, "C").Value & "@" & Cells(J, "D").Value 'F '
Next J
ReDim Arr(1 To Rws, 1 To 4) '? 3 '
Set Rng = [A27].Resize(Rws) 'F3 '
[s27].Resize(Rws).Interior.ColorIndex = 0 'H4 '
For Each Cls In Range([s27], [s27].End(xlDown)) 'H4 '
Set sRng = Rng.Find(Cls.Value & "@" & Cls.Offset(, 1).Value, , xlFormulas, xlWhole)
If sRng Is Nothing Then
W = W + 1: Arr(W, 1) = Cls.Value
Arr(W, 2) = Cls.Offset(, 1).Value: Arr(W, 3) = Cls.Offset(, 2).Value '/ 4 '
Else
Cls.Interior.ColorIndex = 38
End If
Next Cls
GoTo GPE
Set Rng = [B4].Resize(Rws)
For Each Cls In Range([H4], [H4].End(xlDown))
If Cls.Interior.ColorIndex = 38 Then
Set sRng = Rng.Find(Cls.Value)
If Not sRng Is Nothing Then
MyAdd = sRng.Address
Do
If sRng.Offset(, 1).Value = Cls.Offset(, 1).Value Then
sRng.Offset(, 3).Value = Cls.Offset(, 2).Value
End If
Set sRng = Rng.FindNext(sRng)
Loop While Not sRng Is Nothing And sRng.Address <> MyAdd
End If
End If
Next Cls
GPE:
If W Then
[c27].End(xlDown).Offset(1).Resize(W, 3).Value = Arr() 'B4 Resize(3)'
End If
End Sub
Em sửa được rồi bác ah, nhưng muốn chèn dòng bất kì theo thứ tự từ A~Z thì sử dụng câu lệnh như thế nào?Tạm 2 công đoạn, còn công đoạn thứ 3 thì chưa hiểu ra làm sao:
PHP:Sub TongHop_A() Dim Rws As Long, W As Integer, J As Long Dim Cls As Range, sRng As Range, Rng As Range Dim MyAdd As String Rws = [B28].CurrentRegion.Rows.Count '4 ' For J = 27 To Rws + 28 '3 - 28 ' Cells(J, "A").Value = Cells(J, "C").Value & "@" & Cells(J, "D").Value 'F ' Next J ReDim Arr(1 To Rws, 1 To 4) '? 3 ' Set Rng = [A27].Resize(Rws) 'F3 ' [s27].Resize(Rws).Interior.ColorIndex = 0 'H4 ' For Each Cls In Range([s27], [s27].End(xlDown)) 'H4 ' Set sRng = Rng.Find(Cls.Value & "@" & Cls.Offset(, 1).Value, , xlFormulas, xlWhole) If sRng Is Nothing Then W = W + 1: Arr(W, 1) = Cls.Value Arr(W, 2) = Cls.Offset(, 1).Value: Arr(W, 3) = Cls.Offset(, 2).Value '/ 4 ' Else Cls.Interior.ColorIndex = 38 End If Next Cls GoTo GPE Set Rng = [B4].Resize(Rws) For Each Cls In Range([H4], [H4].End(xlDown)) If Cls.Interior.ColorIndex = 38 Then Set sRng = Rng.Find(Cls.Value) If Not sRng Is Nothing Then MyAdd = sRng.Address Do If sRng.Offset(, 1).Value = Cls.Offset(, 1).Value Then sRng.Offset(, 3).Value = Cls.Offset(, 2).Value End If Set sRng = Rng.FindNext(sRng) Loop While Not sRng Is Nothing And sRng.Address <> MyAdd End If End If Next Cls GPE: If W Then [c27].End(xlDown).Offset(1).Resize(W, 3).Value = Arr() 'B4 Resize(3)' End If End Sub
Dữ liệu file mới khác thứ tự dòng với file bài #1, khi áp dụng vào file thực tế phải tự chỉnh địa chỉ mớiDạ bác HiếuCD file đây ạ, đã ra kết quả như mong muốn nhưng dòng tiêu đêff bị nhảy xuống cuối bảng tính ạ.
em muốn hỏi thêm nữa là em muốn chạy và trả ra kết quả trực tiếp trên sheet 1 thì làm như thế nào ạ?
Dữ liệu file mới khác thứ tự dòng với file bài #1, khi áp dụng vào file thực tế phải tự chỉnh địa chỉ mớiDạ bác HiếuCD file đây ạ, đã ra kết quả như mong muốn nhưng dòng tiêu đêff bị nhảy xuống cuối bảng tính ạ.
em muốn hỏi thêm nữa là em muốn chạy và trả ra kết quả trực tiếp trên sheet 1 thì làm như thế nào ạ?