phongkiemtinh
Thành viên thường trực




- Tham gia
- 22/7/09
- Bài viết
- 224
- Được thích
- 5
GPE cho e hỏi xem có code nào giúp lệnh thực thi trong code mình viết chỉ có tác dụng với những sheet được chỉ định không ah. E có code sau:
1/ trong module:
Option Explicit
Public Chk As Boolean, Dic As Object, aResult()
Sub Aut
pen()
Dim wks As Worksheet, SrcRng As Range, sArray
Dim lR As Long, I As Long, J As Long, n As Long, tmp
On Error Resume Next
Set wks = Sheets("Gcas list")
Set SrcRng = wks.Range("A1:B65536")
sArray = SrcRng.Value
ReDim aResult(1 To UBound(sArray, 1), 1 To UBound(sArray, 2))
Set Dic = CreateObject("Scripting.Dictionary")
For I = 1 To UBound(sArray, 1)
If CStr(sArray(I, 1)) <> "" Then
tmp = sArray(I, 1)
If Not Dic.exists(tmp) Then
lR = lR + 1
Dic.Add tmp, lR
For J = 1 To 2
aResult(lR, J) = sArray(I, J)
Next
End If
End If
Next
End Sub
2./ code trong worksheet:
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
' nhap cong thuc do tim gcas tra ve cot Name,size
Application.ScreenUpdating = False
Dim rTarget As Range, aTarget, I As Long, J As Long, n As Long, TG As Double
Dim Arr(), tmp
On Error Resume Next
If Dic Is Nothing Then Aut
pen
If Not Intersect(Range("G3:G65536"), Target) Is Nothing Then
Set rTarget = Intersect(Range("G3:G65536"), Target)
If IsArray(rTarget.Value) Then
aTarget = rTarget.Value
Else
ReDim aTarget(1 To 1, 1 To 1)
aTarget(1, 1) = rTarget.Value
End If
ReDim Arr(1 To UBound(aTarget, 1), 1 To 3)
For I = 1 To UBound(aTarget, 1)
If aTarget(I, 1) <> "" Then
tmp = aTarget(I, 1)
If Dic.exists(tmp) Then
For J = 2 To 3
Arr(I, J - 1) = aResult(Dic.Item(tmp), J)
Next
End If
End If
Next
rTarget.Offset(, 2).Resize(, 2).Value = Arr
End If
Application.ScreenUpdating = True
End Sub
---->>>>>vậy có cách nào giúp e them dòng code chỉ có hiệu lực với 1 số sheet chứ không phải toàn workbook?xin xem file đính kèm code của e có tác dụng trên toàn workbook nên khi vào sheet "tonghop" e tổng hợp theo ngày thì ở cột và cột [J] không hiển thị (e kiểm tra là do ảnh hưởng code trên, bỏ code thì bình thường). Pass :gpe
1/ trong module:
Option Explicit
Public Chk As Boolean, Dic As Object, aResult()
Sub Aut

Dim wks As Worksheet, SrcRng As Range, sArray
Dim lR As Long, I As Long, J As Long, n As Long, tmp
On Error Resume Next
Set wks = Sheets("Gcas list")
Set SrcRng = wks.Range("A1:B65536")
sArray = SrcRng.Value
ReDim aResult(1 To UBound(sArray, 1), 1 To UBound(sArray, 2))
Set Dic = CreateObject("Scripting.Dictionary")
For I = 1 To UBound(sArray, 1)
If CStr(sArray(I, 1)) <> "" Then
tmp = sArray(I, 1)
If Not Dic.exists(tmp) Then
lR = lR + 1
Dic.Add tmp, lR
For J = 1 To 2
aResult(lR, J) = sArray(I, J)
Next
End If
End If
Next
End Sub
2./ code trong worksheet:
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
' nhap cong thuc do tim gcas tra ve cot Name,size
Application.ScreenUpdating = False
Dim rTarget As Range, aTarget, I As Long, J As Long, n As Long, TG As Double
Dim Arr(), tmp
On Error Resume Next
If Dic Is Nothing Then Aut

If Not Intersect(Range("G3:G65536"), Target) Is Nothing Then
Set rTarget = Intersect(Range("G3:G65536"), Target)
If IsArray(rTarget.Value) Then
aTarget = rTarget.Value
Else
ReDim aTarget(1 To 1, 1 To 1)
aTarget(1, 1) = rTarget.Value
End If
ReDim Arr(1 To UBound(aTarget, 1), 1 To 3)
For I = 1 To UBound(aTarget, 1)
If aTarget(I, 1) <> "" Then
tmp = aTarget(I, 1)
If Dic.exists(tmp) Then
For J = 2 To 3
Arr(I, J - 1) = aResult(Dic.Item(tmp), J)
Next
End If
End If
Next
rTarget.Offset(, 2).Resize(, 2).Value = Arr
End If
Application.ScreenUpdating = True
End Sub
---->>>>>vậy có cách nào giúp e them dòng code chỉ có hiệu lực với 1 số sheet chứ không phải toàn workbook?xin xem file đính kèm code của e có tác dụng trên toàn workbook nên khi vào sheet "tonghop" e tổng hợp theo ngày thì ở cột và cột [J] không hiển thị (e kiểm tra là do ảnh hưởng code trên, bỏ code thì bình thường). Pass :gpe