Sửa code vòng lặp For- next trong sổ cái (2 người xem)

Elx Liên hệ QC

Người dùng đang xem chủ đề này

Đang trực tuyến: 1 (Thành viên: 0, Khách: 1)
hoangtrong_vbnd

hoangtrong_vbnd

Thành viên hoạt động
Tham gia
14/1/11
Bài viết
156
Được thích
7
Giới tính
Nam
E có xem bài của bác XuanThanh bên Web kế toán hướng dẫn làm sổ cái theo các dạng, khi áp dụng cho mẫu sổ cái của cty thì có 2 cột Mã khách hàng và tên khách hàng nên code phải sửa lại cho phù hợp. Tuy nhiên e chưa biết cách sửa lại cho phù hợp nên code chay lung tung.
Mong các pro sửa dùm e 1 chút để macro chay cho phù hợp với sổ. E cảm ơn!
 

File đính kèm

Sắp xếp theo thời gian sắp xếp theo bầu chọn
hoangtrong_vbnd đã viết:
E có xem bài của bác XuanThanh bên Web kế toán hướng dẫn làm sổ cái theo các dạng, khi áp dụng cho mẫu sổ cái của cty thì có 2 cột Mã khách hàng và tên khách hàng nên code phải sửa lại cho phù hợp. Tuy nhiên e chưa biết cách sửa lại cho phù hợp nên code chay lung tung.
Mong các pro sửa dùm e 1 chút để macro chay cho phù hợp với sổ. E cảm ơn!
Nhấp chuột vào đây để mở rộng...
Sub LocForNext()
Application.ScreenUpdating = False
On Error GoTo Thoat
Set WsN = Worksheets("NKC")
Set WsD = Worksheets("SOCAI")
Set Vung = WsD.Range("A1:C3")
m = WsN.Range("D65000").End(xlUp).Row
n = WsD.Range("D65000").End(xlUp).Row
TK = WsD.Range("D5").Value
'Xoa du lieu cu cua sheet SOCAI
If n > 10 Then WsD.Range("A11:H" & n).Clear
'Dung vong lap de gan du lieu
For i = 9 To m
If WsN.Range("G" & i) = TK Then
n = WsD.Range("D65000").End(xlUp).Row
WsN.Range("B" & i & ":D" & i).Copy Destination:=WsD.Range("A" & n + 1)
WsN.Range("G" & i).Copy Destination:=WsD.Range("D" & n + 1)
WsD.Range("E" & n + 1) = WsN.Range("H" & i)
WsD.Range("G" & n + 1) = WsN.Range("I" & i)
ElseIf WsN.Range("H" & i) = TK Then
n = WsD.Range("D65000").End(xlUp).Row
WsN.Range("B" & i & ":D" & i).Copy Destination:=WsD.Range("A" & n + 1)
WsN.Range("G" & i).Copy Destination:=WsD.Range("D" & n + 1)
WsD.Range("E" & n + 1) = WsN.Range("I" & i)
WsD.Range("H" & n + 1) = WsN.Range("j" & i)
End If
Next
n = WsD.Range("D65000").End(xlUp).Row
WsD.Range("A11:H" & n + 2).Font.Size = 8
WsD.Range("G11:H" & n + 2).NumberFormat = "#,##0"
WsD.Range("D" & n + 1) = WsD.Range("D1")
WsD.Range("D" & n + 2) = WsD.Range("D2")
WsD.Range("G" & n + 1 & ":H" & n + 1).Formula = "=SUM(R11C:R" & n & "C)"
WsD.Range("G" & n + 1 & ":H" & n + 1).Value = WsD.Range("G" & n + 1 & ":H" & n + 1).Value
Tong = WsD.Range("G10") - WsD.Range("H10") + WsD.Range("G" & n + 1) - WsD.Range("H" & n + 1)
If Tong > 0 Then WsD.Range("F" & n + 2) = Tong Else WsD.Range("G" & n + 2) = Abs(Tong)
If n > 10 Then Call LineDot(WsD.Range("A11:H" & n))
Call LineThin(WsD.Range("A" & n + 1 & ":H" & n + 2))
Exit Sub
Application.ScreenUpdating = True
Thoat:
Exit Sub
End Sub
Mình không làm nghề kế toán, nhưng theo mình thì bạn sửa 2 dòng trong code theo 2 dòng mình đổi màu xanh . Bạn thử xem !
 
Upvote 0
thanks bác :) tuy nhiên chạy macro xong nó mới chỉ xuất ra có một bên số tiền nợ. Làm sao để cho nó chạy theo 1 hoặc cả 2 điều kiện bên sheet sổ cái đây. Mong các bác giúp đỡ!
Dưới đây là file e sửa theo HD của bác
 
Lần chỉnh sửa cuối:
Upvote 0
Bạn phải nêu rõ yêu cầu và ví dụ bởi vì thành viên GFE làm nghề kế toán ít lắm . phần nào được rồi, phần nào chưa được ? 2 điều kiện là thế nào ? Đâu phải ai cũng có thể hiểu nghiệp vụ kế toán . À mà mình hơi hiểu một tý . bạn chép code sau thay code cũ xem sao !
Sub LocForNext()
Application.ScreenUpdating = False
On Error GoTo Thoat
Set WsN = Worksheets("NKC")
Set WsD = Worksheets("SOCAI")
Set Vung = WsD.Range("A1:C3")
m = WsN.Range("D65000").End(xlUp).Row
n = WsD.Range("D65000").End(xlUp).Row
TK = WsD.Range("D5").Value
'Xoa du lieu cu cua sheet SOCAI
If n > 10 Then WsD.Range("A11:H" & n).Clear
'Dung vong lap de gan du lieu
For i = 9 To m
If WsN.Range("I" & i) = TK Then
n = WsD.Range("D65000").End(xlUp).Row
WsN.Range("B" & i & ":D" & i).Copy Destination:=WsD.Range("A" & n + 1)
WsN.Range("G" & i).Copy Destination:=WsD.Range("D" & n + 1)
WsD.Range("E" & n + 1) = WsN.Range("h" & i)
WsD.Range("G" & n + 1) = WsN.Range("J" & i)
ElseIf WsN.Range("H" & i) = TK Then
n = WsD.Range("D65000").End(xlUp).Row
WsN.Range("B" & i & ":D" & i).Copy Destination:=WsD.Range("A" & n + 1)
WsN.Range("G" & i).Copy Destination:=WsD.Range("D" & n + 1)
WsD.Range("E" & n + 1) = WsN.Range("I" & i)
WsD.Range("H" & n + 1) = WsN.Range("J" & i)
End If
Next
n = WsD.Range("D65000").End(xlUp).Row
WsD.Range("A11:H" & n + 2).Font.Size = 8
WsD.Range("G11:H" & n + 2).NumberFormat = "#,##0"
WsD.Range("D" & n + 1) = WsD.Range("D1")
WsD.Range("D" & n + 2) = WsD.Range("D2")
WsD.Range("G" & n + 1 & ":H" & n + 1).Formula = "=SUM(R11C:R" & n & "C)"
WsD.Range("G" & n + 1 & ":H" & n + 1).Value = WsD.Range("G" & n + 1 & ":H" & n + 1).Value
Tong = WsD.Range("G10") - WsD.Range("H10") + WsD.Range("G" & n + 1) - WsD.Range("H" & n + 1)
If Tong > 0 Then WsD.Range("F" & n + 2) = Tong Else WsD.Range("G" & n + 2) = Abs(Tong)
If n > 10 Then Call LineDot(WsD.Range("A11:H" & n))
Call LineThin(WsD.Range("A" & n + 1 & ":H" & n + 2))
Exit Sub
Application.ScreenUpdating = True
Thoat:
Exit Sub
End Sub
 
Lần chỉnh sửa cuối:
Upvote 0
Cảm ơn bác nhiều. E muốn lọc theo 2 điều kiện đó là tài khoản và mã khách hàng và ở đây mới chỉ lọc theo 1 điều kiện là tài khoản
thứ nhất: khi nhập mã tài khoản vào ô vàng (chưa nhập mã khách hàng) thì sẽ lọc theo điều kiện tài khoản 3 ký tự hoặc 4 ký tự (ví dụ 1561 thì có thể lọc theo 156 hoặc 1561
thứ hai: khi nhập thêm mã khách hàng thì sẽ lọc đồng thời cả 2 điều kiện là mã tài khoản và mã khách hàng
 

File đính kèm

Lần chỉnh sửa cuối:
Upvote 0
hoangtrong_vbnd đã viết:
Cảm ơn bác nhiều. E muốn lọc theo 2 điều kiện đó là tài khoản và mã khách hàng và ở đây mới chỉ lọc theo 1 điều kiện là tài khoản
thứ nhất: khi nhập mã tài khoản vào ô vàng (chưa nhập mã khách hàng) thì sẽ lọc theo điều kiện tài khoản 3 ký tự hoặc 4 ký tự (ví dụ 1561 thì có thể lọc theo 156 hoặc 1561
thứ hai: khi nhập thêm mã khách hàng thì sẽ lọc đồng thời cả 2 điều kiện là mã tài khoản và mã khách hàng
Nhấp chuột vào đây để mở rộng...

Copy đoạn code này vào Module chạy code

[GPECODE=vb]


Sub SOCAIGPE()
Dim iR As Long, endR As Long, sR As Long, sSHTK As String
Dim ArrData(), MyDic As Object, MKH As String
With Sheets("NKC")
endR = .Cells(65000, 2).End(xlUp).Row
ArrData = .Range("A4:J" & endR).Value
End With
Dim ArrSocai(1 To 65000, 1 To 8)
Set MyDic = CreateObject("scripting.dictionary")
With Sheets("SOCAI")
sSHTK = CStr(.Range("C5").Value)
MKH = .Range("C6").Value
.Range("A11:H6500").Clear
End With
MyDic.Add sSHTK, ""
For iR = 1 To UBound(ArrData)
If MKH <> "" Then
If ArrData(iR, 5) = MKH Then
If MyDic.Exists(CStr(ArrData(iR, 8))) Then

sR = sR + 1
ArrSocai(sR, 1) = ArrData(iR, 1)
ArrSocai(sR, 2) = ArrData(iR, 2)
ArrSocai(sR, 3) = ArrData(iR, 3)
ArrSocai(sR, 4) = ArrData(iR, 7)
ArrSocai(sR, 5) = ArrData(iR, 9)
ArrSocai(sR, 6) = ArrData(iR, 5)
ArrSocai(sR, 7) = ArrData(iR, 10)

End If
If MyDic.Exists(CStr(ArrData(iR, 9))) Then
sR = sR + 1
ArrSocai(sR, 1) = ArrData(iR, 1)
ArrSocai(sR, 2) = ArrData(iR, 2)
ArrSocai(sR, 3) = ArrData(iR, 3)
ArrSocai(sR, 4) = ArrData(iR, 7)
ArrSocai(sR, 5) = ArrData(iR, 8)
ArrSocai(sR, 6) = ArrData(iR, 5)
ArrSocai(sR, 8) = ArrData(iR, 10)

End If
End If
End If
If MKH = "" Then

If MyDic.Exists(CStr(ArrData(iR, 8))) Then

sR = sR + 1
ArrSocai(sR, 1) = ArrData(iR, 1)
ArrSocai(sR, 2) = ArrData(iR, 2)
ArrSocai(sR, 3) = ArrData(iR, 3)
ArrSocai(sR, 4) = ArrData(iR, 7)
ArrSocai(sR, 5) = ArrData(iR, 9)
ArrSocai(sR, 6) = ArrData(iR, 5)
ArrSocai(sR, 7) = ArrData(iR, 10)

End If
If MyDic.Exists(CStr(ArrData(iR, 9))) Then
sR = sR + 1
ArrSocai(sR, 1) = ArrData(iR, 1)
ArrSocai(sR, 2) = ArrData(iR, 2)
ArrSocai(sR, 3) = ArrData(iR, 3)
ArrSocai(sR, 4) = ArrData(iR, 7)
ArrSocai(sR, 5) = ArrData(iR, 8)
ArrSocai(sR, 6) = ArrData(iR, 5)
ArrSocai(sR, 8) = ArrData(iR, 10)

End If
End If




Next
If sR Then


With Sheets("SOCAI").Range("A11")

.Resize(sR, 8).Value = ArrSocai
.Offset(, 6).Resize(sR, 2).NumberFormat = "#,##0"
.Offset(, 2).Resize(sR, 1).NumberFormat = "dd/mm/yyyy"
.Offset(sR, 3).Value = "Phát sinh trong k" & ChrW(7923)
.Offset(sR + 1, 3).Value = "S" & ChrW(7889) & " d" & ChrW(432) & " cu" & ChrW(7889) & "i k" & ChrW(7923)
.Offset(sR, 6).Value = "=SUM(R11C:R" & sR + 10 & "C)"
.Offset(sR, 7).Value = "=SUM(R11C:R" & sR + 10 & "C)"
Call LineDot(.Resize(sR, 8))
Call LineThin(.Offset(sR).Resize(2, 8))
End With
End If
Set MyDic = Nothing
Erase ArrData, ArrSocai
End Sub
Private Function LineDot(Rng As Range)
With Rng
.Borders(xlEdgeLeft).LineStyle = xlContinuous
.Borders(xlEdgeRight).LineStyle = xlContinuous
.Borders(xlEdgeBottom).LineStyle = xlContinuous
.Borders(xlEdgeTop).LineStyle = xlContinuous
.Borders(xlInsideVertical).LineStyle = xlContinuous
.Borders(xlInsideHorizontal).LineStyle = xlDot
End With
End Function


Private Function LineThin(Rng As Range)
With Rng
.Borders(xlEdgeLeft).LineStyle = xlContinuous
.Borders(xlEdgeRight).LineStyle = xlContinuous
.Borders(xlEdgeBottom).LineStyle = xlContinuous
.Borders(xlEdgeTop).LineStyle = xlContinuous
.Borders(xlInsideVertical).LineStyle = xlContinuous
.Borders(xlInsideHorizontal).LineStyle = xlContinuous
End With
End Function


[/GPECODE]

Nếu có đọc nhấn cảm ơn nhen
 
Upvote 0
nmhung49 đã viết:
Private Function LineDot(Rng As Range)
With Rng
.Borders(xlEdgeLeft).LineStyle = xlContinuous
.Borders(xlEdgeRight).LineStyle = xlContinuous
.Borders(xlEdgeBottom).LineStyle = xlContinuous
.Borders(xlEdgeTop).LineStyle = xlContinuous
.Borders(xlInsideVertical).LineStyle = xlContinuous
.Borders(xlInsideHorizontal).LineStyle = xlDot
End With
End Function


Private Function LineThin(Rng As Range)
With Rng
.Borders(xlEdgeLeft).LineStyle = xlContinuous
.Borders(xlEdgeRight).LineStyle = xlContinuous
.Borders(xlEdgeBottom).LineStyle = xlContinuous
.Borders(xlEdgeTop).LineStyle = xlContinuous
.Borders(xlInsideVertical).LineStyle = xlContinuous
.Borders(xlInsideHorizontal).LineStyle = xlContinuous
End With
End Function
Nhấp chuột vào đây để mở rộng...

Bạn thử sửa lại code kẻ bảng như dưới đây xem có được không (tôi chưa test công thức của bạn)

Mã: 
Private Function LineDot(Rng As Range)
    With Rng
        .Borders.LineStyle = 1
        .Borders(12).LineStyle = 2
    End With
End Function


Private Function LineThin(Rng As Range)
    Rng.Borders.LineStyle = 1
End Function
 
Lần chỉnh sửa cuối:
Upvote 0
- Sửa code của nmhung49 cho gọn lại.
- BỎ Dictionary, Dic 1 phần tử thì xài làm chi cho khổ.
- Dùng sub thay cho function, và là sub có tham số truyền.
- Biến ArrSocai() khai báo tối đa bằng với số dòng của Data, chứ khai báo chi 65000 dòng cho hao tốn.

PHP: 
Sub SOCAIGPE()
Dim iR As Long, endR As Long, sR As Long, sSHTK As String
Dim ArrData(), ArrSocai(), MKH As String
With Sheets("NKC")
  endR = .Cells(65000, 2).End(xlUp).Row
  ArrData = .Range("A4:J" & endR).Value
End With
ReDim ArrSocai(1 To endR, 1 To 8)

With Sheets("Socai")
  sSHTK = CStr(.Range("C5").Value)
  MKH = .Range("C6").Value
  .Range("A11:H6500").Clear
End With
For iR = 1 To UBound(ArrData)
If MKH <> "" Then
    If ArrData(iR, 5) = MKH Then
        If ArrData(iR, 8) = sSHTK Or ArrData(iR, 9) = sSHTK Then
            sR = sR + 1
            ArrSocai(sR, 1) = ArrData(iR, 1)
            ArrSocai(sR, 2) = ArrData(iR, 2)
            ArrSocai(sR, 3) = ArrData(iR, 3)
            ArrSocai(sR, 4) = ArrData(iR, 7)
            ArrSocai(sR, 6) = ArrData(iR, 5)
            If ArrData(iR, 8) = sSHTK Then
                ArrSocai(sR, 5) = ArrData(iR, 9)
                ArrSocai(sR, 7) = ArrData(iR, 10)
            Else
                ArrSocai(sR, 5) = ArrData(iR, 8)
                ArrSocai(sR, 8) = ArrData(iR, 10)
            End If
        End If
    End If
Else
    If ArrData(iR, 8) = sSHTK Or ArrData(iR, 9) = sSHTK Then
        sR = sR + 1
        ArrSocai(sR, 1) = ArrData(iR, 1)
        ArrSocai(sR, 2) = ArrData(iR, 2)
        ArrSocai(sR, 3) = ArrData(iR, 3)
        ArrSocai(sR, 4) = ArrData(iR, 7)
        ArrSocai(sR, 6) = ArrData(iR, 5)
        If ArrData(iR, 8) = sSHTK Then
            ArrSocai(sR, 5) = ArrData(iR, 9)
            ArrSocai(sR, 7) = ArrData(iR, 10)
        Else
            ArrSocai(sR, 5) = ArrData(iR, 8)
            ArrSocai(sR, 8) = ArrData(iR, 10)
        End If
    End If
End If
Next
If sR Then
 
With Sheets("SOCAI").Range("A11")
     
    .Resize(sR, 8).Value = ArrSocai
    .Offset(, 6).Resize(sR, 2).NumberFormat = "#,##0"
    .Offset(, 2).Resize(sR, 1).NumberFormat = "dd/mm/yyyy"
    .Offset(sR, 3).Value = "Phát sinh trong k" & ChrW(7923)
    .Offset(sR + 1, 3).Value = "S" & ChrW(7889) & " d" & ChrW(432) & " cu" & ChrW(7889) & "i k" & ChrW(7923)
    .Offset(sR, 6).Value = "=SUM(R11C:R" & sR + 10 & "C)"
    .Offset(sR, 7).Value = "=SUM(R11C:R" & sR + 10 & "C)"
End With
End If
BorderS Sheets("Socai").Range("A11").Resize(sR, 8)
BorderS Sheets("Socai").Range("A11").Offset(sR, 0).Resize(2, 8)
Erase ArrData, ArrSocai
End Sub
'--------------------------------------'
Sub BorderS(Rng As Range)
On Error Resume Next
    With Rng
    For i = 7 To 12
        .BorderS(i).LineStyle = 1
        .BorderS(i).Weight = IIf(i = 12, 1, 2)
    Next
    End With
End Sub
 
Lần chỉnh sửa cuối:
Upvote 0
Cảm ơn các bác nhiều!
Không có cách nào để nhập tài khoản tổng hợp so với các tài khoản bên NKC thì sổ cái vẫn chạy ạ.
VD như bên NKC chỉ khai báo là 1561 và 1562 thì e muốn lọc tổng hợp đối ứng với tất cả các tài khoản có đối ứng với 2 tài khoản này thì nhập 156
--> làm sao để cho nó chạy luôn cả tổng hợp đây. Mong các bác giúp đỡ :)
 
Upvote 0
hoangtrong_vbnd đã viết:
Cảm ơn các bác nhiều!
Không có cách nào để nhập tài khoản tổng hợp so với các tài khoản bên NKC thì sổ cái vẫn chạy ạ.
VD như bên NKC chỉ khai báo là 1561 và 1562 thì e muốn lọc tổng hợp đối ứng với tất cả các tài khoản có đối ứng với 2 tài khoản này thì nhập 156
--> làm sao để cho nó chạy luôn cả tổng hợp đây. Mong các bác giúp đỡ :)
Nhấp chuột vào đây để mở rộng...

Sửa lại code này xem sao

[GPECODE=vb]


Sub SOCAIGPE1()
Dim iR As Long, endR As Long, sR As Long, sSHTK As String
Dim ArrData(), ArrSocai(), MKH As String
With Sheets("NKC")
endR = .Cells(65000, 2).End(xlUp).Row
ArrData = .Range("A4:J" & endR).Value
End With
ReDim ArrSocai(1 To endR, 1 To 8)


With Sheets("Socai")
sSHTK = CStr(.Range("C5").Value)
MKH = .Range("C6").Value
.Range("A11:H6500").Clear
End With
For iR = 1 To UBound(ArrData)
If MKH <> "" Then
If ArrData(iR, 5) = MKH Then
If ArrData(iR, 8) Like sSHTK & "*" Or ArrData(iR, 9) Like sSHTK & "*" Then
sR = sR + 1
ArrSocai(sR, 1) = ArrData(iR, 1)
ArrSocai(sR, 2) = ArrData(iR, 2)
ArrSocai(sR, 3) = ArrData(iR, 3)
ArrSocai(sR, 4) = ArrData(iR, 7)
ArrSocai(sR, 6) = ArrData(iR, 5)
If ArrData(iR, 8) Like sSHTK & "*" Then
ArrSocai(sR, 5) = ArrData(iR, 9)
ArrSocai(sR, 7) = ArrData(iR, 10)
Else
ArrSocai(sR, 5) = ArrData(iR, 8)
ArrSocai(sR, 8) = ArrData(iR, 10)
End If
End If
End If
Else
If ArrData(iR, 8) Like sSHTK & "*" Or ArrData(iR, 9) Like sSHTK & "*" Then
sR = sR + 1
ArrSocai(sR, 1) = ArrData(iR, 1)
ArrSocai(sR, 2) = ArrData(iR, 2)
ArrSocai(sR, 3) = ArrData(iR, 3)
ArrSocai(sR, 4) = ArrData(iR, 7)
ArrSocai(sR, 6) = ArrData(iR, 5)
If ArrData(iR, 8) Like sSHTK & "*" Then
ArrSocai(sR, 5) = ArrData(iR, 9)
ArrSocai(sR, 7) = ArrData(iR, 10)
Else
ArrSocai(sR, 5) = ArrData(iR, 8)
ArrSocai(sR, 8) = ArrData(iR, 10)
End If
End If
End If
Next
If sR Then

With Sheets("SOCAI").Range("A11")

.Resize(sR, 8).Value = ArrSocai
.Offset(, 6).Resize(sR, 2).NumberFormat = "#,##0"
.Offset(, 2).Resize(sR, 1).NumberFormat = "dd/mm/yyyy"
.Offset(sR, 3).Value = "Phát sinh trong k" & ChrW(7923)
.Offset(sR + 1, 3).Value = "S" & ChrW(7889) & " d" & ChrW(432) & " cu" & ChrW(7889) & "i k" & ChrW(7923)
.Offset(sR, 6).Value = "=SUM(R11C:R" & sR + 10 & "C)"
.Offset(sR, 7).Value = "=SUM(R11C:R" & sR + 10 & "C)"
BorderS Sheets("Socai").Range("A11").Resize(sR, 8)
BorderS Sheets("Socai").Range("A11").Offset(sR, 0).Resize(2, 8)
End With
End If


Erase ArrData, ArrSocai
End Sub
'--------------------------------------'
Sub BorderS(Rng As Range)
Dim i As Long
On Error Resume Next

With Rng
For i = 7 To 12
.BorderS(i).LineStyle = 1
.BorderS(i).Weight = IIf(i = 12, 1, 2)
Next
End With
End Sub
[/GPECODE]
 
Upvote 0
bác chỉ e nên mua sách gì về tự học với ... thấy các bác viết hay quá mà ko biết học thế nào.
(p/s: e ở hà nội)
 
Upvote 0
Nhờ mọi người chỉ mình cách đặt font mặc định trong đoạn code trên
ví dụ: Font "Times New Roman" và Cỡ chứ Size 10
Xin cảm ơn!
 
Lần chỉnh sửa cuối:
Upvote 0
Có ai biết chỉnh font chữ và cỡ chữ trong đoạn code bác nmhung ko chỉ e với ạ.
Ví dụ: Font "Times New Roman" Size "10"
Cảm ơn mọi người!
 
Upvote 0
nmhung49 đã viết:
Sửa lại code này xem sao

[GPECODE=vb]


Sub SOCAIGPE1()
Dim iR As Long, endR As Long, sR As Long, sSHTK As String
Dim ArrData(), ArrSocai(), MKH As String
With Sheets("NKC")
endR = .Cells(65000, 2).End(xlUp).Row
ArrData = .Range("A4:J" & endR).Value
End With
ReDim ArrSocai(1 To endR, 1 To 8)


With Sheets("Socai")
sSHTK = CStr(.Range("C5").Value)
MKH = .Range("C6").Value
.Range("A11:H6500").Clear
End With
For iR = 1 To UBound(ArrData)
If MKH <> "" Then
If ArrData(iR, 5) = MKH Then
If ArrData(iR, 8) Like sSHTK & "*" Or ArrData(iR, 9) Like sSHTK & "*" Then
sR = sR + 1
ArrSocai(sR, 1) = ArrData(iR, 1)
ArrSocai(sR, 2) = ArrData(iR, 2)
ArrSocai(sR, 3) = ArrData(iR, 3)
ArrSocai(sR, 4) = ArrData(iR, 7)
ArrSocai(sR, 6) = ArrData(iR, 5)
If ArrData(iR, 8) Like sSHTK & "*" Then
ArrSocai(sR, 5) = ArrData(iR, 9)
ArrSocai(sR, 7) = ArrData(iR, 10)
Else
ArrSocai(sR, 5) = ArrData(iR, 8)
ArrSocai(sR, 8) = ArrData(iR, 10)
End If
End If
End If
Else
If ArrData(iR, 8) Like sSHTK & "*" Or ArrData(iR, 9) Like sSHTK & "*" Then
sR = sR + 1
ArrSocai(sR, 1) = ArrData(iR, 1)
ArrSocai(sR, 2) = ArrData(iR, 2)
ArrSocai(sR, 3) = ArrData(iR, 3)
ArrSocai(sR, 4) = ArrData(iR, 7)
ArrSocai(sR, 6) = ArrData(iR, 5)
If ArrData(iR, 8) Like sSHTK & "*" Then
ArrSocai(sR, 5) = ArrData(iR, 9)
ArrSocai(sR, 7) = ArrData(iR, 10)
Else
ArrSocai(sR, 5) = ArrData(iR, 8)
ArrSocai(sR, 8) = ArrData(iR, 10)
End If
End If
End If
Next
If sR Then

With Sheets("SOCAI").Range("A11")

.Resize(sR, 8).Value = ArrSocai
.Offset(, 6).Resize(sR, 2).NumberFormat = "#,##0"
.Offset(, 2).Resize(sR, 1).NumberFormat = "dd/mm/yyyy"
.Offset(sR, 3).Value = "Phát sinh trong k" & ChrW(7923)
.Offset(sR + 1, 3).Value = "S" & ChrW(7889) & " d" & ChrW(432) & " cu" & ChrW(7889) & "i k" & ChrW(7923)
.Offset(sR, 6).Value = "=SUM(R11C:R" & sR + 10 & "C)"
.Offset(sR, 7).Value = "=SUM(R11C:R" & sR + 10 & "C)"
BorderS Sheets("Socai").Range("A11").Resize(sR, 8)
BorderS Sheets("Socai").Range("A11").Offset(sR, 0).Resize(2, 8)
End With
End If


Erase ArrData, ArrSocai
End Sub
'--------------------------------------'
Sub BorderS(Rng As Range)
Dim i As Long
On Error Resume Next

With Rng
For i = 7 To 12
.BorderS(i).LineStyle = 1
.BorderS(i).Weight = IIf(i = 12, 1, 2)
Next
End With
End Sub
[/GPECODE]
Nhấp chuột vào đây để mở rộng...

Mã: 
With Sheets("Socai")
sSHTK = CStr(.Range("C5").Value)
MKH = .Range("C6").Value
.Range("A11:H6500").Clear
End With

Đoạn này chắc phải sửa thành D5 và D6 anh nhẩy, em sửa xong thấy chạy ầm ầm
 
Upvote 0
Bạn phải đăng nhập hoặc đăng ký để trả lời bài viết tại đây.

Bài viết mới nhất

L
Tính thời gian làm việc thực tế
Trả lời
66
Đọc
14K
YenTon
Y
H
Chia sẻ file in Phiếu điều tra PCGD
    • Thích
    • Yêu thích
    • Cảm ơn
Trả lời
13
Đọc
628
Phuong7686
P
GPE-Trợ Lý
  • Dán lên cao
[KHẨN] HƯỚNG VỀ ĐỒNG BÀO CHỊU ẢNH HƯỞNG CỦA BÃO YAGI - BẢO YÊN, LÀO CAI (2 người xem)
    • Thích
    • Cảm ơn
    • Yêu thích
Trả lời
91
Đọc
14K
SA_DQ
SA_DQ
SA_DQ
Copilot bình luận về một ván cờ vua
    • Thích
Trả lời
6
Đọc
409
SA_DQ
SA_DQ
92nguyenthanh
  • Question Question
Vba cho file nhập xuất kho
Trả lời
4
Đọc
110
HUONGHCKT
H
C
Fix lỗi Application.InputBox Type:=8
    • Cười
Trả lời
25
Đọc
618
ptm0412
ptm0412
GPE-Trợ Lý
[GPE] TALK SHOW 08: GIẢI QUYẾT VẤN ĐỀ TỐI ƯU HÓA TRONG EXCEL VỚI CÔNG CỤ SOLVER
    • Thích
    • Cảm ơn
Trả lời
4
Đọc
3K
DuongLeHung
D
Gà Công Nghệ
Chế độ chính sách cho giáo viên mầm non giữ trẻ khuyết tật
Trả lời
1
Đọc
57
vanle33
vanle33
huuthang_bd
Add-in DeleteVirusMacro - Xóa và ngăn chặn virus macro
    • Thích
    • Yêu thích
    • Cảm ơn
Trả lời
56
Đọc
22K
dunghtgiga
dunghtgiga
L
  • Question Question
Viết code tìm kiếm các file trong Folder
Trả lời
40
Đọc
12K
lan nguyen0987
L
P
Hyperlink_Cách chuyển cả thư mục và file tổng hợp sang máy khác không bị lỗi (1 người xem)
Trả lời
5
Đọc
108
phongvanvu
P
HeSanbi
Tiện ích Web: Tự động nhấn nút "Bỏ qua" quảng cáo Youtube
    • Thích
    • Yêu thích
Trả lời
14
Đọc
1K
ongke0711
ongke0711
ptm0412
Quá tin tưởng vào AI các thể loại
    • Cười
Trả lời
4
Đọc
218
Maika8008
Maika8008
A
  • Question Question
Không tìm được lỗi code
Trả lời
6
Đọc
159
ptm0412
ptm0412
W
Tham chiếu theo chuỗi ký tự
Trả lời
8
Đọc
315
dungpham01
D
tritv.dad
Lấy dữ liệu từ folder các tờ khai thông quan để theo dõi hiệu suất công việc.
Trả lời
8
Đọc
287
BlueSphere
B
GPE-Trợ Lý
MỪNG NGÀY NHÀ GIÁO VIỆT NAM 20/11 (1 người xem)
    • Thích
Trả lời
0
Đọc
3K
GPE-Trợ Lý
GPE-Trợ Lý
SA_DQ
Xin chúc mừng các thầy cô giáo trên cộng đồng nhân 20/11
    • Thích
    • Yêu thích
Trả lời
1
Đọc
135
BuiQuangThuan
B
M
chuyển đổi số thành chữ
Trả lời
15
Đọc
371
dungpham01
D
V
Lỗi copy sheet: the name already exists.
Trả lời
7
Đọc
702
nghiabros
N
Xem thêm…

Thành viên có số lượng bài viết cao nhất tháng

Thành viên có điểm tương tác cao nhất tháng

Thời gian đếm ngược.

000
Ngày
00
Giờ
00
phút
00
giây
Thân mời tham dự sự kiện sinh nhật GPE 2025
Back
Top Bottom