Copy này vào thay thế đoạn code bạn có
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, [F6:F8]) Is Nothing And UCase(Target.Value) = "OK" Then
Sheet1.Range(Target.Offset(, -1).Address).Value = "EMPTY"
End If
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
If Target.Column = 6 Then
If UCase(Target) = "OK" Then
With Sheets("Sheet1").[a65536].End(3)
Range(Cells(Target.Row, 1), Cells(Target.Row, 4)).Copy .Offset(1)
.Offset(1, 4) = "EMPTY"
End With
End If
End If
End SubThì bạn thay code trên = code sau:
Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
If Target.Column = 8 Then
If UCase(Target) = "OK" Then
With Sheets("Sheet1").[a65536].End(3)
Range(Cells(Target.Row, 1), Cells(Target.Row, 7)).Copy .Offset(1)
.Offset(1, 4) = "EMPTY"
End With
End If
End If
End Sub
Điều kiện theo như bạn mô tả phải bỏ cột seal ra chứ bạn.Uh, mình mới học tập tọe thôi, đa số học nhanh để đáp ứng công việc chứ chưa đi lên từ căn bản
Gửi bạn Hai Lúa Miền Tây: cảm ơn bạn vì đã giúp mình đoạn code trên, giờ mình muốn sau khi Copy lệnh sang sheet2 thì nó sum lại như sheet1(file đính kèm). Bạn giúp mình nhé!
Private Sub Worksheet_Activate()
Dim cn As New ADODB.Connection
Dim adoRS As New ADODB.Recordset
On Error GoTo BaoLoi
With cn
.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & ThisWorkbook.FullName & _
";Extended Properties=""Excel 8.0;HDR=No;"";"
.Open
End With
With adoRS
.ActiveConnection = cn
.Open "SELECT F1, '' as T1,'' as T2, F4,F5,F6,F7,F8, SUM(F9) FROM [Sheet2$A6:I65000] " & _
"GROUP BY F1, F4,F5,F6,F7,F8 " & _
"HAVING SUM(F9) >0"
End With
Sheets("Sheet1").Range("A6").CopyFromRecordset adoRS
adoRS.Close: cn.Close
Set cn = Nothing: Set adoRS = Nothing
Exit Sub
BaoLoi:
MsgBox Err.Description
End Sub
Vậy còn khỏe nữa.
Public Sub GPE()
Dim Rng(), Arr(), I As Long, J As Long, K As Long, Dic As Object, Tem As Variant
Set Dic = CreateObject("Scripting.Dictionary")
With Sheets("Data")
Rng = .Range(.[A6], .[A65000].End(xlUp)).Resize(, 10).Value
End With
ReDim Arr(1 To UBound(Rng, 1), 1 To 9)
For I = 1 To UBound(Rng, 1)
If UCase(Rng(I, 10)) = "OK" Then
Tem = Rng(I, 1)
If Not Dic.Exists(Tem) Then
K = K + 1
Dic.Add Tem, K
Arr(K, 1) = Tem
For J = 4 To 9
Arr(K, J) = Rng(I, J)
Next J
Else
Arr(Dic.Item(Tem), 9) = Arr(Dic.Item(Tem), 9) + Rng(I, 9)
End If
End If
Next I
With Sheets("GPE")
.[A6:I1000].ClearContents
If K Then .[A6].Resize(K, 9).Value = Arr
End With
Set Dic = Nothing
End Sub
