LamNA
Thành viên tích cực
- Tham gia
- 3/6/14
- Bài viết
- 897
- Được thích
- 720
- Giới tính
- Nam
- Nghề nghiệp
- Quản Lý Cửa Hàng
Bài này 1 vòng lặp @LamNA dư sức làm.Chào anh chị
Nhờ anh chị viết giúp đoạn code như sau:
- Dựa vào cột AR và AY lấy số khoán sheet "SK" theo ngành hàng và tháng tương ứng
- Lấy cột BC (Doanh _Thu) chia cho cột BD (TARGET) ra % hoàn thành
Em cám ơn
Thay ban code nhieu ma bai toan nay cung lam kho ban sao? May minh unicode co van de. hicChào anh chị
Nhờ anh chị viết giúp đoạn code như sau:
- Dựa vào cột AR và AY lấy số khoán sheet "SK" theo ngành hàng và tháng tương ứng
- Lấy cột BC (Doanh _Thu) chia cho cột BD (TARGET) ra % hoàn thành
Em cám ơn
Em là bóc lụm thôi nhìn biết sửa mà nghĩ câu lệnh thì chưa tư duy, tìm bài viết áp dụng chắc được tại đang online điện thoại chưa tìm đượcThay ban code nhieu ma bai toan nay cung lam kho ban sao? May minh unicode co van de. hic
Hộ em luôn nha anhBài này 1 vòng lặp @LamNA dư sức làm.
Vậy oánh thử.Hộ em luôn nha anh
Sub GetSK()
Dim skRng As Range, xF As Range, nhArr(), i As Long, Lr As Long, tgArr()
Lr = Sheet2.Range("AR65535").End(xlUp).Row
nhArr = Sheet2.Range("AR2:BC" & Lr).Value
Set skRng = Sheet1.Range("A3:A12")
ReDim tgArr(1 To UBound(nhArr, 1), 1 To 2)
Sheet2.Range("BD2:BE65535").ClearContents
For i = 1 To UBound(nhArr, 1)
Set xF = skRng.Find(nhArr(i, 1), , , 1)
If Not xF Is Nothing Then
tgArr(i, 1) = xF.Offset(, nhArr(i, 8))
tgArr(i, 2) = nhArr(i, 12) / tgArr(i, 1)
End If
Next i
Sheet2.Range("BD2").Resize(i - 1, 2) = tgArr
End Sub
À em tính viết nối theo đoạn code trong sheet DATA dùng sự kiện worksheet_change mà để lên máy chắc bốc ghép vào được. Cám ơn a nhaVậy oánh thử.
Không biết phải đang bị đánh đố gì không đây.
Mã:Sub GetSK() Dim skRng As Range, xF As Range, nhArr(), i As Long, Lr As Long, tgArr() Lr = Sheet2.Range("AR65535").End(xlUp).Row nhArr = Sheet2.Range("AR2:BC" & Lr).Value Set skRng = Sheet1.Range("A3:A12") ReDim tgArr(1 To UBound(nhArr, 1), 1 To 2) Sheet2.Range("BD2:BE65535").ClearContents For i = 1 To UBound(nhArr, 1) Set xF = skRng.Find(nhArr(i, 1), , , 1) If Not xF Is Nothing Then tgArr(i, 1) = xF.Offset(, nhArr(i, 8)) tgArr(i, 2) = nhArr(i, 12) / tgArr(i, 1) End If Next i Sheet2.Range("BD2").Resize(i - 1, 2) = tgArr End Sub
Em ráp thử nếu dùng sub riêng thì làm được nhưng ráp thử với sự kiện worksheet_change trong sheet "data" hình như bị chớt vớtVậy oánh thử.
Không biết phải đang bị đánh đố gì không đây.
Mã:Sub GetSK() Dim skRng As Range, xF As Range, nhArr(), i As Long, Lr As Long, tgArr() Lr = Sheet2.Range("AR65535").End(xlUp).Row nhArr = Sheet2.Range("AR2:BC" & Lr).Value Set skRng = Sheet1.Range("A3:A12") ReDim tgArr(1 To UBound(nhArr, 1), 1 To 2) Sheet2.Range("BD2:BE65535").ClearContents For i = 1 To UBound(nhArr, 1) Set xF = skRng.Find(nhArr(i, 1), , , 1) If Not xF Is Nothing Then tgArr(i, 1) = xF.Offset(, nhArr(i, 8)) tgArr(i, 2) = nhArr(i, 12) / tgArr(i, 1) End If Next i Sheet2.Range("BD2").Resize(i - 1, 2) = tgArr End Sub
' cot BC
Set change = Intersect(Target, Range("AR2:BC600000"))
Set skRng = Sheet1.Range("A3:A12")
If Not change Is Nothing Then
ReDim tgArr(1 To UBound(change, 1), 1 To 2)
For i = 1 To UBound(change, 1)
Set xF = skRng.Find(change(i, 1), , , 1)
If Not xF Is Nothing Then
tgArr(i, 1) = xF.Offset(, change(i, 8))
tgArr(i, 2) = change(i, 12) / tgArr(i, 1)
End If
Next i
Sheet2.Range("BD2").Resize(i - 1, 2) = tgArr
End If
Test thử nha @LamNAEm ráp thử nếu dùng sub riêng thì làm được nhưng ráp thử với sự kiện worksheet_change trong sheet "data" hình như bị chớt vớt
Mã:' cot BC Set change = Intersect(Target, Range("AR2:BC600000")) Set skRng = Sheet1.Range("A3:A12") If Not change Is Nothing Then ReDim tgArr(1 To UBound(change, 1), 1 To 2) For i = 1 To UBound(change, 1) Set xF = skRng.Find(change(i, 1), , , 1) If Not xF Is Nothing Then tgArr(i, 1) = xF.Offset(, change(i, 8)) tgArr(i, 2) = change(i, 12) / tgArr(i, 1) End If Next i Sheet2.Range("BD2").Resize(i - 1, 2) = tgArr End If
Dim i As Long, tmp, Res(), S As Variant, iKey, sRow As Long, sRng As Range, xF As Range
Dim result(), cot2(), ba(), change As Range, songayma As String, so_ngay_ma As Object
'-----------------------------------------
Application.EnableEvents = False
Application.ScreenUpdating = False
Set change = Intersect(Range("A2:AQ600000"), Target)
' ngay thang
Set change = Intersect(Target, Range("O2:O65535"))
If Not change Is Nothing Then
Set sRng = Sheet1.Range("A3:A11")
result = change.Resize(change.Rows.Count + 1).Value
ReDim Preserve result(1 To UBound(result), 1 To 5)
'-------------------------------------------
Set xF = sRng.Find(Target.Offset(, 29).Value, , , 1)
If Not xF Is Nothing Then
Target.Offset(, 41).Value = xF.Offset(, Target.Offset(, 36).Value)
Target.Offset(, 42).Value = Target.Offset(, 40).Value / Target.Offset(, 41).Value
End If
'-------------------------------------------
For i = 1 To UBound(result) - 1
If Len(result(i, 1)) Then
result(i, 2) = Format(result(i, 1), "[$-42A]ddd")
result(i, 3) = Format(result(i, 1), "d")
result(i, 4) = Format(result(i, 1), "m")
result(i, 5) = Format(result(i, 1), "yyyy")
result(i, 1) = Format(result(i, 1), "ww")
End If
Next i
change.Offset(0, 33).Resize(, 5).Value = result
End If
Cám ơn anh trước nha chút lên máy tính chạy thử nhìn cũng hình được chút để lên vọc . heheTest thử nha @LamNA
Mã:Dim i As Long, tmp, Res(), S As Variant, iKey, sRow As Long, sRng As Range, xF As Range Dim result(), cot2(), ba(), change As Range, songayma As String, so_ngay_ma As Object '----------------------------------------- Application.EnableEvents = False Application.ScreenUpdating = False Set change = Intersect(Range("A2:AQ600000"), Target) ' ngay thang Set change = Intersect(Target, Range("O2:O65535")) If Not change Is Nothing Then Set sRng = Sheet1.Range("A3:A11") result = change.Resize(change.Rows.Count + 1).Value ReDim Preserve result(1 To UBound(result), 1 To 5) '------------------------------------------- Set xF = sRng.Find(Target.Offset(, 29).Value, , , 1) If Not xF Is Nothing Then Target.Offset(, 41).Value = xF.Offset(, Target.Offset(, 36).Value) Target.Offset(, 42).Value = Target.Offset(, 40).Value / Target.Offset(, 41).Value End If '------------------------------------------- For i = 1 To UBound(result) - 1 If Len(result(i, 1)) Then result(i, 2) = Format(result(i, 1), "[$-42A]ddd") result(i, 3) = Format(result(i, 1), "d") result(i, 4) = Format(result(i, 1), "m") result(i, 5) = Format(result(i, 1), "yyyy") result(i, 1) = Format(result(i, 1), "ww") End If Next i change.Offset(0, 33).Resize(, 5).Value = result End If
Hình như gõ từng ô thì ra còn copy 1 lượt thì lỗi bác ơiTest thử nha @LamNA
Mã:Dim i As Long, tmp, Res(), S As Variant, iKey, sRow As Long, sRng As Range, xF As Range Dim result(), cot2(), ba(), change As Range, songayma As String, so_ngay_ma As Object '----------------------------------------- Application.EnableEvents = False Application.ScreenUpdating = False Set change = Intersect(Range("A2:AQ600000"), Target) ' ngay thang Set change = Intersect(Target, Range("O2:O65535")) If Not change Is Nothing Then Set sRng = Sheet1.Range("A3:A11") result = change.Resize(change.Rows.Count + 1).Value ReDim Preserve result(1 To UBound(result), 1 To 5) '------------------------------------------- Set xF = sRng.Find(Target.Offset(, 29).Value, , , 1) If Not xF Is Nothing Then Target.Offset(, 41).Value = xF.Offset(, Target.Offset(, 36).Value) Target.Offset(, 42).Value = Target.Offset(, 40).Value / Target.Offset(, 41).Value End If '------------------------------------------- For i = 1 To UBound(result) - 1 If Len(result(i, 1)) Then result(i, 2) = Format(result(i, 1), "[$-42A]ddd") result(i, 3) = Format(result(i, 1), "d") result(i, 4) = Format(result(i, 1), "m") result(i, 5) = Format(result(i, 1), "yyyy") result(i, 1) = Format(result(i, 1), "ww") End If Next i change.Offset(0, 33).Resize(, 5).Value = result End If
Trong code Change từ ô 1 (Target.Count=1) thì 2 cột cuối ra bình thường.Em chưa hiểu phần này mình đọan nào vậy anh?
Thử codeEm ráp thử nếu dùng sub riêng thì làm được nhưng ráp thử với sự kiện worksheet_change trong sheet "data" hình như bị chớt vớt
Mã:' cot BC Set change = Intersect(Target, Range("AR2:BC600000")) Set skRng = Sheet1.Range("A3:A12") If Not change Is Nothing Then ReDim tgArr(1 To UBound(change, 1), 1 To 2) For i = 1 To UBound(change, 1) Set xF = skRng.Find(change(i, 1), , , 1) If Not xF Is Nothing Then tgArr(i, 1) = xF.Offset(, change(i, 8)) tgArr(i, 2) = change(i, 12) / tgArr(i, 1) End If Next i Sheet2.Range("BD2").Resize(i - 1, 2) = tgArr End If
Private Sub Worksheet_Change(ByVal Target As Range)
Dim i As Long
Dim result(), ba(), change As Range
'-----------------------------------------
Application.EnableEvents = False
Application.ScreenUpdating = False
' ngay thang
Set change = Intersect(Target, Range("O2:O600000"))
If Not change Is Nothing Then
result = change.Resize(change.Rows.Count + 1).Value
ReDim Preserve result(1 To UBound(result), 1 To 5)
For i = 1 To UBound(result) - 1
If Len(result(i, 1)) Then
result(i, 2) = Format(result(i, 1), "[$-42A]ddd")
result(i, 3) = Format(result(i, 1), "d")
result(i, 4) = Format(result(i, 1), "m")
result(i, 5) = Format(result(i, 1), "yyyy")
result(i, 1) = Format(result(i, 1), "ww")
End If
Next i
change.Offset(0, 33).Resize(, 5).Value = result
' cot BD va BE
Call HoanThanhDinhMuc(change)
End If
' Phan Khuc Gia va cot BA
Set change = Intersect(Target, Range("AE2:AE600000"))
If Not change Is Nothing Then
result = change.Resize(change.Rows.Count + 1).Value
ba = result
For i = 1 To UBound(result) - 1
If Len(result(i, 1)) Then
ba(i, 1) = result(i, 1) / 1.1
Select Case result(i, 1) / 10 ^ 6
Case Is <= 1: result(i, 1) = "<1M"
Case Is <= 2: result(i, 1) = "1M-2M"
Case Is <= 4: result(i, 1) = "2M-4M"
Case Is <= 6: result(i, 1) = "4M-6M"
Case Is <= 8: result(i, 1) = "6M-8M"
Case Is <= 10: result(i, 1) = "8M-10M"
Case Is <= 12: result(i, 1) = "10M-12M"
Case Is <= 14: result(i, 1) = "12M-14M"
Case Is <= 16: result(i, 1) = "14M-16M"
Case Is <= 18: result(i, 1) = "16M-18M"
Case Is <= 20: result(i, 1) = "18M-20M"
Case Else: result(i, 1) = "Tren 20M"
End Select
End If
Next i
' Phan Khuc Gia COT AO
change.Offset(, 16).Value = result
' cot BC
change.Offset(, 24).Value = ba
' cot BD va BE
Call HoanThanhDinhMuc(change)
End If
' cot BD va BE
Set change = Intersect(Target, Range("AR2:AR600000"))
If Not change Is Nothing Then Call HoanThanhDinhMuc(change)
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
Private Sub HoanThanhDinhMuc(ByVal Rng As Range)
Dim nHang As Range, Thang As Range, DoanhThu As Range, sArr(), result()
Dim i As Long, fRow As Long, sRow As Long, tmp As String
fRow = Rng.Row: sRow = Rng.Rows.Count
Set nHang = Range("AR" & fRow).Resize(sRow)
Set Thang = Range("AY" & fRow).Resize(sRow)
Set DoanhThu = Range("BC" & fRow).Resize(sRow)
ReDim result(1 To sRow, 1 To 2)
sArr = Sheets("SK").Range("A3:M11").Value
For i = 1 To sRow
If Len(Thang(i, 1)) > 0 Then
tmp = nHang(i, 1)
For n = 1 To UBound(sArr)
If sArr(n, 1) = tmp Then
result(i, 1) = sArr(n, Thang(i, 1) + 1)
result(i, 2) = DoanhThu(i, 1) / result(i, 1)
Exit For
End If
Next n
End If
Next i
Range("BD" & fRow).Resize(sRow, 2) = result
End Sub
Dạ cám ơn bác nhaThử code
Mã:Private Sub Worksheet_Change(ByVal Target As Range) Dim i As Long Dim result(), ba(), change As Range '----------------------------------------- Application.EnableEvents = False Application.ScreenUpdating = False ' ngay thang Set change = Intersect(Target, Range("O2:O600000")) If Not change Is Nothing Then result = change.Resize(change.Rows.Count + 1).Value ReDim Preserve result(1 To UBound(result), 1 To 5) For i = 1 To UBound(result) - 1 If Len(result(i, 1)) Then result(i, 2) = Format(result(i, 1), "[$-42A]ddd") result(i, 3) = Format(result(i, 1), "d") result(i, 4) = Format(result(i, 1), "m") result(i, 5) = Format(result(i, 1), "yyyy") result(i, 1) = Format(result(i, 1), "ww") End If Next i change.Offset(0, 33).Resize(, 5).Value = result ' cot BD va BE Call HoanThanhDinhMuc(change) End If ' Phan Khuc Gia va cot BA Set change = Intersect(Target, Range("AE2:AE600000")) If Not change Is Nothing Then result = change.Resize(change.Rows.Count + 1).Value ba = result For i = 1 To UBound(result) - 1 If Len(result(i, 1)) Then ba(i, 1) = result(i, 1) / 1.1 Select Case result(i, 1) / 10 ^ 6 Case Is <= 1: result(i, 1) = "<1M" Case Is <= 2: result(i, 1) = "1M-2M" Case Is <= 4: result(i, 1) = "2M-4M" Case Is <= 6: result(i, 1) = "4M-6M" Case Is <= 8: result(i, 1) = "6M-8M" Case Is <= 10: result(i, 1) = "8M-10M" Case Is <= 12: result(i, 1) = "10M-12M" Case Is <= 14: result(i, 1) = "12M-14M" Case Is <= 16: result(i, 1) = "14M-16M" Case Is <= 18: result(i, 1) = "16M-18M" Case Is <= 20: result(i, 1) = "18M-20M" Case Else: result(i, 1) = "Tren 20M" End Select End If Next i ' Phan Khuc Gia COT AO change.Offset(, 16).Value = result ' cot BC change.Offset(, 24).Value = ba ' cot BD va BE Call HoanThanhDinhMuc(change) End If ' cot BD va BE Set change = Intersect(Target, Range("AR2:AR600000")) If Not change Is Nothing Then Call HoanThanhDinhMuc(change) Application.EnableEvents = True Application.ScreenUpdating = True End Sub Private Sub HoanThanhDinhMuc(ByVal Rng As Range) Dim nHang As Range, Thang As Range, DoanhThu As Range, sArr(), result() Dim i As Long, fRow As Long, sRow As Long, tmp As String fRow = Rng.Row: sRow = Rng.Rows.Count Set nHang = Range("AR" & fRow).Resize(sRow) Set Thang = Range("AY" & fRow).Resize(sRow) Set DoanhThu = Range("BC" & fRow).Resize(sRow) ReDim result(1 To sRow, 1 To 2) sArr = Sheets("SK").Range("A3:M11").Value For i = 1 To sRow If Len(Thang(i, 1)) > 0 Then tmp = nHang(i, 1) For n = 1 To UBound(sArr) If sArr(n, 1) = tmp Then result(i, 1) = sArr(n, Thang(i, 1) + 1) result(i, 2) = DoanhThu(i, 1) / result(i, 1) Exit For End If Next n End If Next i Range("BD" & fRow).Resize(sRow, 2) = result End Sub