Tìm số khoán theo tháng

Liên hệ QC

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
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
 

File đính kèm

  • Test.xlsb
    81.1 KB · Đọc: 13
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
Bài này 1 vòng lặp @LamNA dư sức làm.
 
Upvote 0
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. hic
 
Upvote 0
Thay ban code nhieu ma bai toan nay cung lam kho ban sao? May minh unicode co van de. hic
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 được
Bài đã được tự động gộp:

Bài này 1 vòng lặp @LamNA dư sức làm.
Hộ em luôn nha anh
 
Upvote 0
Vậ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
 
Upvote 0
Vậ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 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 nha
 
Upvote 0
Vậ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ớ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
 

File đính kèm

  • Test (1).xlsb
    81.4 KB · Đọc: 12
Upvote 0
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ớ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
Test 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
 

File đính kèm

  • Test (1).xlsm
    607.1 KB · Đọc: 10
Upvote 0
Test 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
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 . hehe
Bài đã được tự động gộp:

Test 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 ơi
216475
 
Lần chỉnh sửa cuối:
Upvote 0
Không chơi Find cho Target.Count > 1 được rồi.
 
Upvote 0
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ớ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
Thử 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
 
Upvote 0
Thử 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
Dạ cám ơn bác nha
 
Upvote 0
Web KT
Back
Top Bottom