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
Cách khác: Sửa code thành vầy sẽ khỏi mất công chỉnh gì gì đó trong Reference:
Private Sub Worksheet_Activate()
Dim cn As Object, adoRS As Object
Set cn = CreateObject("ADODB.Connection")
Set adoRS = CreateObject("ADODB.Recordset")
On Error GoTo ErrHandler
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
ErrHandler:
MsgBox Err.Description
End Sub
10000, trong đó A55 là tiêu đề. Vậy bạn có thể xóa bớt để chừa lại khoảng 10 dòng ---> Dữ liệu còn lại là A514Bạn xóa bớt dữ liệu, tôi đồng ý, nhưng ít ra phải giữ lại CẤU TRÚC cho nó giống y chang với dữ liệu thật của bạn chứ!
Ví dụ: Dữ liệu của bạn đặt tại A5
Những thứ không được xóa và thay đổi:
- Tiêu đề cột tại các sheet
- Tên sheet
vân vân... Nói chung là không được thay đổi CẤU TRÚC ---> Bạn có hiểu không nhỉ?
Ban đầu phải nói luôn đỡ phải mất thời gian, bạn thử code sau nhé.
Private Sub Worksheet_Activate()
Dim cn As Object, adoRS As Object
Set cn = CreateObject("ADODB.Connection")
Set adoRS = CreateObject("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 '' as T, F2,F3, '' as T1,'' as T2, F6,F7,F8,F9,F10,SUM(F11), F12 FROM [Copy$A6:L65000] " & _
"GROUP BY F2,F3, F6,F7,F8,F9,F10,F12 " & _
"HAVING SUM(F11) >0"
End With
Sheets("Sum").Range("A6").CopyFromRecordset adoRS
adoRS.Close: cn.Close
Set cn = Nothing: Set adoRS = Nothing
Exit Sub
BaoLoi:
MsgBox Err.Description
End SubPrivate Sub Worksheet_Activate()
Dim cn As Object, adoRS As Object
Set cn = CreateObject("ADODB.Connection")
Set adoRS = CreateObject("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 '' as T,F2,F3,'' as T1,'' as T2, F6,F7,F8,F9,F10,SUM(F11), Sum(F12) FROM [Copy$A6:L65000] " & _
"GROUP BY F2,F3,F6,F7,F8,F9,F10 " & _
"HAVING SUM(F11) >0"
End With
With Sheets("Sum")
.Range("A6:L65000").ClearContents
.Range("A6").CopyFromRecordset adoRS
With .Range("A6:A" & .Range("B65000").End(xlUp).Row)
.FormulaR1C1 = "=ROW()-5"
.Value = .Value
End With
End With
adoRS.Close: cn.Close
Set cn = Nothing: Set adoRS = Nothing
Exit Sub
BaoLoi:
MsgBox Err.Description
End SubBạn chỉnh cột đó về dạng Text là được.
