Giúp sửa code chọn tài khoản để in

Liên hệ QC
H

Hongha0412

Thành viên mới
Tham gia
28/8/17
Bài viết
20
Được thích
8
Giới tính
Nam
Tôi có file dùng để in sổ kế toán cần sửa code do có tình huống phát sinh mới.
Ví dụ: cần in sổ TK642 (TK chi tiết là 6421,6422), thì trong dữ liệu chỉ có 6421,6422, nên chưa thể in TK642 được.
Yêu cầu cụ thể trong file đính kèm.
 

File đính kèm

Lần chỉnh sửa cuối:
Sắp xếp theo thời gian sắp xếp theo bầu chọn
Mới Edit lại
Mã: 
Sub InSoCai()
    Dim sArr(), dArr(), I As Long, J As Long
    Dim SoTK As Long, TKno As Long, TKco As Long, Er As Long
SoTK = Sheets("So").Range("D4").Value
With Sheets("T01")
    Er = .Range("D" & Rows.Count).End(xlUp).Row
    If Er < 7 Then Exit Sub
    sArr = .Range("D7:D" & Er).Resize(, 7).Value
End With
ReDim dArr(1 To UBound(sArr), 1 To 6)
For I = 1 To UBound(sArr)
    If sArr(I, 5) <> Empty Then TKno = Left(sArr(I, 5), 3)
    If sArr(I, 6) <> Empty Then TKco = Left(sArr(I, 6), 3)
    If TKno = SoTK Or TKco = SoTK Then
        K = K + 1
        For J = 1 To 4
            dArr(K, J) = sArr(I, J)
        Next J
        If TKno = SoTK Then dArr(K, 5) = sArr(I, 7)
        If TKco = SoTK Then dArr(K, 6) = sArr(I, 7)
    End If
Next I
With Sheets("So")
    .Range("A13:F5000").Clear
    If K Then
        With .Range("A13").Resize(K, 6)
            .Value = dArr
            .Borders.LineStyle = xlContinuous
            .Borders(xlInsideHorizontal).Weight = xlHairline
        End With
        Er = .Range("A" & Rows.Count).End(xlUp).Row
        .Range("A13:A" & Er).HorizontalAlignment = xlCenter
        .Range("C13:C" & Er).HorizontalAlignment = xlLeft
        Union(.Range("B13:B" & Er), .Range("E13:F" & Er)).HorizontalAlignment = xlRight
        .Range("E13:F" & Er).NumberFormat = "#,##0"
        .Range("C" & Er + 1) = .Range("J4")
        .Range("E" & Er + 1) = "=Sum(E13:E" & Er & ")"
        .Range("F" & Er + 1) = "=Sum(F13:F" & Er & ")"
        With .Range("A" & Er + 1 & ": F" & Er + 1)
            .Borders.LineStyle = xlContinuous
            .Font.Bold = True
        End With
        .Range("D" & Er + 3) = .Range("J3")
        .Range("A" & Er + 4) = .Range("J2"):  .Range("A" & Er + 9) = .Range("J5")
        .Range("D" & Er + 4) = .Range("J4"):  .Range("D" & Er + 9) = .Range("J6")
        .Range("A" & Er + 4 & ": C" & Er + 9).HorizontalAlignment = xlCenterAcrossSelection
        .Range("D" & Er + 3 & ": F" & Er + 9).HorizontalAlignment = xlCenterAcrossSelection
        ActiveSheet.PageSetup.PrintArea = "$A$1:$F" & Er + 9
    End If
End With
End Sub
 
Lần chỉnh sửa cuối:
Upvote 0
congnguyen88 đã viết:
Mã: 
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = "$D$4" Or Target.Address = "$G$1" Then Call SoCai
End Sub
Public Sub SoCai()
Dim sArr(), dArr(), R As Long, I As Long, J As Long, K As Long, TK As Long, Col As Long, Sh As String, col2 As Long
Dim Str1 As String, Str2 As String, Str3 As String, Str4 As String, Str5 As String, Str6 As String
Sh = [G1].Value
With Sheets(Sh)
    sArr = .Range(.[D7], .[D7].End(xlDown)).Resize(, 7).Value
End With
ReDim dArr(1 To UBound(sArr, 1), 1 To 6)
With Sheets("So")
    TK = .Range("D4").Value
    Str1 = .[J1].Value: Str2 = .[J2].Value
    Str3 = .[J3].Value: Str4 = .[J4].Value
    Str5 = .[J5].Value: Str6 = .[J6].Value
    For I = 1 To UBound(sArr, 1)
        If sArr(I, 5) = TK Or sArr(I, 6) = TK Then
            K = K + 1
            Col = IIf(sArr(I, 5) = Tk
        Dim Str1 As String, Str2 As String, Str3 As String, Str4 As String, Str5 As String, Str6 As String
Sh = [G1].Value
With Sheets(Sh)
    sArr = .Range(.[D7], .[D7].End(xlDown)).Resize(, 7).Value
End With
ReDim dArr(1 To UBound(sArr, 1), 1 To 6)
With Sheets("So")
    TK = .Range("D4").Value
    Str1 = .[J1].Value: Str2 = .[J2].Value
    Str3 = .[J3].Value: Str4 = .[J4].Value
    Str5 = .[J5].Value: Str6 = .[J6].Value
    For I = 1 To UBound(sArr, 1)
        If sArr(I, 5) = TK Or sArr(I, 6) = TK Then
            K = K + 1
            Col = IIf(sArr(I, 5) = TK, 5, 6)
            For J = 1 To 3
            For J = 1 To 3
                dArr(K, J) = sArr(I, J)
            Next J
                dArr(K, Col) = sArr(I, 7)
                dArr(K, 4) = sArr(I, IIf(sArr(I, 5) = TK, 6, 5))
        End If
    Next I
   
        TK = .Range("D4").Value
    Str1 = .[J1].Value: Str2 = .[J2].Value
    Str3 = .[J3].Value: Str4 = .[J4].Value
    Str5 = .[J5].Value: Str6 = .[J6].Value
    For I = 1 To UBound(sArr, 1)
        If sArr(I, 5) = TK Or sArr(I, 6) = TK Then
            K = K + 1
            Col = IIf(sArr(I, 5) = TK, 5, 6)
            For J = 1 To 3
                dArr(K, J) = sArr(I, J)
            Next J
           
            Dim Str1 As String, Str2 As String, Str3 As String, Str4 As String, Str5 As String, Str6 As String
Sh = [G1].Value
With Sheets(Sh)
    sArr = .Range(.[D7], .[D7].End(xlDown)).Resize(, 7).Value
End With
ReDim dArr(1 To UBound(sArr, 1), 1 To 6)
With Sheets("So")
    TK = .Range("D4").Value
    Str1 = .[J1].Value: Str2 = .[J2].Value
    Str3 = .[J3].Value: Str4 = .[J4].Value
    Str5 = .[J5].Value: Str6 = .[J6].Value
    For I = 1 To UBound(sArr, 1)
        If sArr(I, 5) = TK Or sArr(I, 6) = TK Then
            K = K + 1
            Col = IIf(sArr(I, 5) = TK, 5, 6)
            For J = 1 To 3
            Dim Str1 As String, Str2 As String, Str3 As String, Str4 As String, Str5 As String, Str6 As String
Sh = [G1].Value
With Sheets(Sh)
    sArr = .Range(.[D7], .[D7].End(xlDown)).Resize(, 7).Value
End With
ReDim dArr(1 To UBound(sArr, 1), 1 To 6)
With Sheets("So")
    TK = .Range("D4").Value
    Str1 = .[J1].Value: Str2 = .[J2].Value
    Str3 = .[J3].Value: Str4 = .[J4].Value
    Str5 = .[J5].Value: Str6 = .[J6].Value
    For I = 1 To UBound(sArr, 1)
        If sArr(I, 5) = TK Or sArr(I, 6) = TK Then
            K = K + 1
            Col = IIf(sArr(I, 5) = TK, 5, 6)
            For J = 1 To 3
           
            Dim Str1 As String, Str2 As String, Str3 As String, Str4 As String, Str5 As String, Str6 As String
Sh = [G1].Value
With Sheets(Sh)
    sArr = .Range(.[D7], .[D7].End(xlDown)).Resize(, 7).Value
End With
ReDim dArr(1 To UBound(sArr, 1), 1 To 6)
With Sheets("So")
    TK = .Range("D4").Value
    Str1 = .[J1].Value: Str2 = .[J2].Value
    Str3 = .[J3].Value: Str4 = .[J4].Value
    Str5 = .[J5].Value: Str6 = .[J6].Value
    For I = 1 To UBound(sArr, 1)
        If sArr(I, 5) = TK Or sArr(I, 6) = TK Then
            K = K + 1
            Col = IIf(sArr(I, 5) = TK, 5, 6)
            For J = 1 To 3
            Dim Str1 As String, Str2 As String, Str3 As String, Str4 As String, Str5 As String, Str6 As String
Sh = [G1].Value
With Sheets(Sh)
Dim Str1 As String, Str2 As String, Str3 As String, Str4 As String, Str5 As String, Str6 As String
Sh = [G1].Value
With Sheets(Sh)
    sArr = .Range(.[D7], .[D7].End(xlDown)).Resize(, 7).Value
End With
ReDim dArr(1 To UBound(sArr, 1), 1 To 6)
With Sheets("So")
    TK = .Range("D4").Value
    Str1 = .[J1].Value: Str2 = .[J2].Value
    Str3 = .[J3].Value: Str4 = .[J4].Value
    Str5 = .[J5].Value: Str6 = .[J6].Value
    For I = 1 To UBound(sArr, 1)
        If sArr(I, 5) = TK Or sArr(I, 6) = TK Then
            K = K + 1
            Col = IIf(sArr(I, 5) = TK, 5, 6)
            For J = 1 To 3
    sArr = .Range(.[D7], .[D7].End(xlDown)).Resize(, 7).Value
End With
ReDim dArr(1 To UBound(sArr, 1), 1 To 6)
With Sheets("So")
    TK = .Range("D4").Value
    Str1 = .[J1].Value: Str2 = .[J2].Value
    Str3 = .[J3].Value: Str4 = .[J4].Value
    Str5 = .[J5].Value: Str6 = .[J6].Value
    For I = 1 To UBound(sArr, 1)
        If sArr(I, 5) = TK Or sArr(I, 6) = TK Then
            K = K + 1
            Col = IIf(sArr(I, 5) = TK, 5, 6)
            For J = 1 To 3
                dArr(K, Col) = sArr(I, 7)
                dArr(K, 4) = sArr(I, IIf(sArr(I, 5) = TK, 6, 5))
        End If
        Dim Str1 As String, Str2 As String, Str3 As String, Str4 As String, Str5 As String, Str6 As String
Sh = [G1].Value
With Sheets(Sh)
    sArr = .Range(.[D7], .[D7].End(xlDown)).Resize(, 7).Value
End With
ReDim dArr(1 To UBound(sArr, 1), 1 To 6)
With Sheets("So")
    TK = .Range("D4").Value
    Str1 = .[J1].Value: Str2 = .[J2].Value
    Str3 = .[J3].Value: Str4 = .[J4].Value
    Str5 = .[J5].Value: Str6 = .[J6].Value
    For I = 1 To UBound(sArr, 1)
        If sArr(I, 5) = TK Or sArr(I, 6) = TK Then
            K = K + 1
            Col = IIf(sArr(I, 5) = TK, 5, 6)
            For J = 1 To 3Dim Str1 As String, Str2 As String, Str3 As String, Str4 As String, Str5 As String, Str6 As String
Sh = [G1].Value
With Sheets(Sh)
    sArr = .Range(.[D7], .[D7].End(xlDown)).Resize(, 7).Value
End With
ReDim dArr(1 To UBound(sArr, 1), 1 To 6)
With Sheets("So")
    TK = .Range("D4").Value
    Str1 = .[J1].Value: Str2 = .[J2].Value
    Str3 = .[J3].Value: Str4 = .[J4].Value
    Str5 = .[J5].Value: Str6 = .[J6].Value
    For I = 1 To UBound(sArr, 1)
        If sArr(I, 5) = TK Or sArr(I, 6) = TK Then
            K = K + 1
            Col = IIf(sArr(I, 5) = TK, 5, 6)
            For J = 1 To 3
    Next I
    .[A13:H1000].ClearContents
    .[A13:H1000].Borders.LineStyle = xlNone
    .[A13:H1000].Font.Bold = False
    .[F13:F1000].HorizontalAlignment = xlGeneral
    If K Then
        .[A13].Resize(K, 6) = dArr
        .[A13].Resize(K + 1, 6).Borders.LineStyle = xlContinuous
        .[A13].Resize(K, 6).Borders(xlInsideHorizontal).Weight = xlHairline
        .[C13].Offset(K) = Str1
        .[E13].Offset(K + 2) = Str3
        .[D13].Offset(K).Resize(, 4).Font.Bold = True
        .[E13:F13].Offset(K) = "=SUM(R13C:R[-1]C)" 'Cong tong Thu, Chi)
        .[B13].Offset(K + 3) = Str2
        .[B13].Offset(K + 8) = Str5
        .[E13].Offset(K + 3) = Str4
        .[E13].Offset(K + 8) = Str6
        .[E13].Offset(K + 2).Resize(7).HorizontalAlignment = xlCenter
        Else
        End If
    With Sheets("So")
        col2 = [k1].Value
        ActiveSheet.PageSetup.PrintArea = "$A$1:$F" & col2
        End With
End With
End Sub
Nhấp chuột vào đây để mở rộng...
Sao Dim str... nhiều vạy
 
Upvote 0
buiquangthuan đã viết:
Em cũng thắc mắc sao anh ấy dim lại nhiều lần thế với mục đích gì vậy nhỉ
Nhấp chuột vào đây để mở rộng...
Thà xử lầm không tha lầm
Hongha0412 đã viết:
Tôi có file dùng để in sổ kế toán cần sửa code do có tình huống phát sinh mới.
Ví dụ: cần in sổ TK642 (TK chi tiết là 6421,6422), thì trong dữ liệu chỉ có 6421,6422, nên chưa thể in TK642 được.
Yêu cầu cụ thể trong file đính kèm.
Nhấp chuột vào đây để mở rộng...
Chỉnh lại các dòng đầu
Mã: 
Public Sub SoCai()
Dim sArr(), dArr(), R As Long, I As Long, J As Long, K As Long, Col As Long, Sh As String, col2 As Long
Dim TK As String, Str1 As String, Str2 As String, Str3 As String, Str4 As String, Str5 As String, Str6 As String

Sh = [G1].Value
With Sheets(Sh)
    sArr = .Range(.[D7], .[D7].End(xlDown)).Resize(, 7).Value
End With
ReDim dArr(1 To UBound(sArr, 1), 1 To 6)
With Sheets("So")
    TK = .Range("D4").Value & "*"
    Str1 = .[J1].Value: Str2 = .[J2].Value
    Str3 = .[J3].Value: Str4 = .[J4].Value
    Str5 = .[J5].Value: Str6 = .[J6].Value
    For I = 1 To UBound(sArr, 1)
        If CStr(sArr(I, 5)) Like TK Or CStr(sArr(I, 6)) Like TK Then
            K = K + 1
            Col = IIf(CStr(sArr(I, 5)) Like TK, 5, 6)
            For J = 1 To 3
                dArr(K, J) = sArr(I, J)
            Next J
                dArr(K, Col) = sArr(I, 7)
                dArr(K, 4) = sArr(I, IIf(CStr(sArr(I, 5)) Like TK, 6, 5))
        End If
    Next I
....
 
Upvote 0
Upvote 0
HieuCD đã viết:
Thà xử lầm không tha lầm

Chỉnh lại các dòng đầu
Mã: 
Public Sub SoCai()
Dim sArr(), dArr(), R As Long, I As Long, J As Long, K As Long, Col As Long, Sh As String, col2 As Long
Dim TK As String, Str1 As String, Str2 As String, Str3 As String, Str4 As String, Str5 As String, Str6 As String

Sh = [G1].Value
With Sheets(Sh)
    sArr = .Range(.[D7], .[D7].End(xlDown)).Resize(, 7).Value
End With
ReDim dArr(1 To UBound(sArr, 1), 1 To 6)
With Sheets("So")
    TK = .Range("D4").Value & "*"
    Str1 = .[J1].Value: Str2 = .[J2].Value
    Str3 = .[J3].Value: Str4 = .[J4].Value
    Str5 = .[J5].Value: Str6 = .[J6].Value
    For I = 1 To UBound(sArr, 1)
        If CStr(sArr(I, 5)) Like TK Or CStr(sArr(I, 6)) Like TK Then
            K = K + 1
            Col = IIf(CStr(sArr(I, 5)) Like TK, 5, 6)
            For J = 1 To 3
                dArr(K, J) = sArr(I, J)
            Next J
                dArr(K, Col) = sArr(I, 7)
                dArr(K, 4) = sArr(I, IIf(CStr(sArr(I, 5)) Like TK, 6, 5))
        End If
    Next I
....
Nhấp chuột vào đây để mở rộng...
Cảm ơn mọi người đã quan tâm và giúp đỡ.
Sau khi test lại, code đã hoạt động đúng ý.
Còn cái code cũ, cũng do mọi người chỉnh sửa giùm, nhưng sau đó mình có sửa thêm cho phù hợp, nên có thể nó hơi lung củng
 

File đính kèm

Upvote 0
Hongha0412 đã viết:
Cảm ơn mọi người đã quan tâm và giúp đỡ.
Sau khi test lại, code đã hoạt động đúng ý.
Còn cái code cũ, cũng do mọi người chỉnh sửa giùm, nhưng sau đó mình có sửa thêm cho phù hợp, nên có thể nó hơi lung củng
Nhấp chuột vào đây để mở rộng...
Cài hoa lá cành sao nó lại dài thế :p:p:p
Mã: 
Sub InSoCai()
    Dim sArr(), dArr(), I As Long, J As Long
    Dim SoTK As Long, TKno As Long, TKco As Long, Er As Long
SoTK = Sheets("So").Range("D4").Value
With Sheets("T01")
    Er = .Range("D" & Rows.Count).End(xlUp).Row
    If Er < 7 Then Exit Sub
    sArr = .Range("D7:D" & Er).Resize(, 7).Value
End With
ReDim dArr(1 To UBound(sArr), 1 To 6)
For I = 1 To UBound(sArr)
    If sArr(I, 5) <> Empty Then TKno = Left(sArr(I, 5), 3)
    If sArr(I, 6) <> Empty Then TKco = Left(sArr(I, 6), 3)
    If TKno = SoTK Or TKco = SoTK Then
        K = K + 1
        For J = 1 To 4
            dArr(K, J) = sArr(I, J)
        Next J
        If TKno = SoTK Then dArr(K, 5) = sArr(I, 7)
        If TKco = SoTK Then dArr(K, 6) = sArr(I, 7)
    End If
Next I
With Sheets("So")
    .Range("A13:F5000").Clear
    If K Then
        With .Range("A13").Resize(K, 6)
            .Value = dArr
            .Borders.LineStyle = xlContinuous
            .Borders(xlInsideHorizontal).Weight = xlHairline
        End With
        Er = .Range("A" & Rows.Count).End(xlUp).Row
        .Range("A13:A" & Er).HorizontalAlignment = xlCenter
        .Range("C13:C" & Er).HorizontalAlignment = xlLeft
        Union(.Range("B13:B" & Er), .Range("E13:F" & Er)).HorizontalAlignment = xlRight
        .Range("E13:F" & Er).NumberFormat = "#,##0"
        .Range("C" & Er + 1) = .Range("J4")
        .Range("E" & Er + 1) = "=Sum(E13:E" & Er & ")"
        .Range("F" & Er + 1) = "=Sum(F13:F" & Er & ")"
        With .Range("A" & Er + 1 & ": F" & Er + 1)
            .Borders.LineStyle = xlContinuous
            .Font.Bold = True
        End With
        .Range("D" & Er + 3) = .Range("J3")
        .Range("A" & Er + 4) = .Range("J2"):  .Range("A" & Er + 9) = .Range("J5")
        .Range("D" & Er + 4) = .Range("J4"):  .Range("D" & Er + 9) = .Range("J6")
        .Range("A" & Er + 4 & ": C" & Er + 9).HorizontalAlignment = xlCenterAcrossSelection
        .Range("D" & Er + 3 & ": F" & Er + 9).HorizontalAlignment = xlCenterAcrossSelection
        ActiveSheet.PageSetup.PrintArea = "$A$1:$F" & Er + 9
    End If
End With
End Sub
Bài đã được tự động gộp:

congnguyen88 đã viết:
chết cha rồi Cô giáo. Mình bị Ctrl V bị lố rồi. Xin lỗi cô giáo
Nhấp chuột vào đây để mở rộng...
Còn nữa kìa người ơi. Chưa xong được đâu (2 cái For I=.........) :p:p:p
 
Lần chỉnh sửa cuối:
Upvote 0
PacificPR đã viết:
Cài hoa lá cành sao nó lại dài thế :p:p:p
Mã: 
Sub InSoCai()
    Dim sArr(), dArr(), I As Long, J As Long
    Dim SoTK As Long, TKno As Long, TKco As Long, Er As Long
SoTK = Sheets("So").Range("D4").Value
With Sheets("T01")
    Er = .Range("D" & Rows.Count).End(xlUp).Row
    If Er < 7 Then Exit Sub
    sArr = .Range("D7:D" & Er).Resize(, 7).Value
End With
ReDim dArr(1 To UBound(sArr), 1 To 6)
For I = 1 To UBound(sArr)
    If sArr(I, 5) <> Empty Then TKno = Left(sArr(I, 5), 3)
    If sArr(I, 6) <> Empty Then TKco = Left(sArr(I, 6), 3)
    If TKno = SoTK Or TKco = SoTK Then
        K = K + 1
        For J = 1 To 4
            dArr(K, J) = sArr(I, J)
        Next J
        If TKno = SoTK Then dArr(K, 5) = sArr(I, 7)
        If TKco = SoTK Then dArr(K, 6) = sArr(I, 7)
    End If
Next I
With Sheets("So")
    .Range("A13:F5000").Clear
    If K Then
        With .Range("A13").Resize(K, 6)
            .Value = dArr
            .Borders.LineStyle = xlContinuous
            .Borders(xlInsideHorizontal).Weight = xlHairline
        End With
        Er = .Range("A" & Rows.Count).End(xlUp).Row
        .Range("A13:A" & Er).HorizontalAlignment = xlCenter
        .Range("C13:C" & Er).HorizontalAlignment = xlLeft
        Union(.Range("B13:B" & Er), .Range("E13:F" & Er)).HorizontalAlignment = xlRight
        .Range("E13:F" & Er).NumberFormat = "#,##0"
        .Range("C" & Er + 1) = .Range("J4")
        .Range("E" & Er + 1) = "=Sum(E13:E" & Er & ")"
        .Range("F" & Er + 1) = "=Sum(F13:F" & Er & ")"
        With .Range("A" & Er + 1 & ": F" & Er + 1)
            .Borders.LineStyle = xlContinuous
            .Font.Bold = True
        End With
        .Range("D" & Er + 3) = .Range("J3")
        .Range("A" & Er + 4) = .Range("J2"):  .Range("A" & Er + 9) = .Range("J5")
        .Range("D" & Er + 4) = .Range("J4"):  .Range("D" & Er + 9) = .Range("J6")
        .Range("A" & Er + 4 & ": C" & Er + 9).HorizontalAlignment = xlCenterAcrossSelection
        .Range("D" & Er + 3 & ": F" & Er + 9).HorizontalAlignment = xlCenterAcrossSelection
        ActiveSheet.PageSetup.PrintArea = "$A$1:$F" & Er + 9
    End If
End With
End Sub
Nhấp chuột vào đây để mở rộng...
Code chạy ok quá. Mà giờ muốn đổi cái font chữ sang times new roman thì sửa chỗ nào vậy bạn.
 
Upvote 0
PacificPR đã viết:
Cài hoa lá cành sao nó lại dài thế :p:p:p
Mã: 
Sub InSoCai()
    Dim sArr(), dArr(), I As Long, J As Long
    Dim SoTK As Long, TKno As Long, TKco As Long, Er As Long
SoTK = Sheets("So").Range("D4").Value
With Sheets("T01")
    Er = .Range("D" & Rows.Count).End(xlUp).Row
    If Er < 7 Then Exit Sub
    sArr = .Range("D7:D" & Er).Resize(, 7).Value
End With
ReDim dArr(1 To UBound(sArr), 1 To 6)
For I = 1 To UBound(sArr)
    If sArr(I, 5) <> Empty Then TKno = Left(sArr(I, 5), 3)
    If sArr(I, 6) <> Empty Then TKco = Left(sArr(I, 6), 3)
    If TKno = SoTK Or TKco = SoTK Then
        K = K + 1
        For J = 1 To 4
            dArr(K, J) = sArr(I, J)
        Next J
        If TKno = SoTK Then dArr(K, 5) = sArr(I, 7)
        If TKco = SoTK Then dArr(K, 6) = sArr(I, 7)
    End If
Next I
With Sheets("So")
    .Range("A13:F5000").Clear
    If K Then
        With .Range("A13").Resize(K, 6)
            .Value = dArr
            .Borders.LineStyle = xlContinuous
            .Borders(xlInsideHorizontal).Weight = xlHairline
        End With
        Er = .Range("A" & Rows.Count).End(xlUp).Row
        .Range("A13:A" & Er).HorizontalAlignment = xlCenter
        .Range("C13:C" & Er).HorizontalAlignment = xlLeft
        Union(.Range("B13:B" & Er), .Range("E13:F" & Er)).HorizontalAlignment = xlRight
        .Range("E13:F" & Er).NumberFormat = "#,##0"
        .Range("C" & Er + 1) = .Range("J4")
        .Range("E" & Er + 1) = "=Sum(E13:E" & Er & ")"
        .Range("F" & Er + 1) = "=Sum(F13:F" & Er & ")"
        With .Range("A" & Er + 1 & ": F" & Er + 1)
            .Borders.LineStyle = xlContinuous
            .Font.Bold = True
        End With
        .Range("D" & Er + 3) = .Range("J3")
        .Range("A" & Er + 4) = .Range("J2"):  .Range("A" & Er + 9) = .Range("J5")
        .Range("D" & Er + 4) = .Range("J4"):  .Range("D" & Er + 9) = .Range("J6")
        .Range("A" & Er + 4 & ": C" & Er + 9).HorizontalAlignment = xlCenterAcrossSelection
        .Range("D" & Er + 3 & ": F" & Er + 9).HorizontalAlignment = xlCenterAcrossSelection
        ActiveSheet.PageSetup.PrintArea = "$A$1:$F" & Er + 9
    End If
End With
End Sub
Bài đã được tự động gộp:


Còn nữa kìa người ơi. Chưa xong được đâu (2 cái For I=.........) :p:p:p
Nhấp chuột vào đây để mở rộng...
Mã: 
Sub InSoCai()
    Dim sArr(), dArr(), I As Long, J As Long
    Dim SoTK As Long, TKno As Long, TKco As Long, Er As Long
SoTK = Sheets("So").Range("D4").Value
With Sheets("T01")
    Er = .Range("D" & Rows.Count).End(xlUp).Row
    If Er < 7 Then Exit Sub
    sArr = .Range("D7:D" & Er).Resize(, 7).Value
End With
ReDim dArr(1 To UBound(sArr), 1 To 6)
For I = 1 To UBound(sArr)
    If sArr(I, 5) <> Empty Then TKno = Left(sArr(I, 5), 3)
    If sArr(I, 6) <> Empty Then TKco = Left(sArr(I, 6), 3)
    If TKno = SoTK Or TKco = SoTK Then
        K = K + 1
        For J = 1 To 4
            dArr(K, J) = sArr(I, J)
        Next J
        If TKno = SoTK Then dArr(K, 5) = sArr(I, 7)
        If TKco = SoTK Then dArr(K, 6) = sArr(I, 7)
    End If
Next I
With Sheets("So")
    .Range("A13:F5000").Clear
    If K Then
        With .Range("A13").Resize(K, 6)
            .Value = dArr
            .Borders.LineStyle = xlContinuous
            .Borders(xlInsideHorizontal).Weight = xlHairline
        End With
        Er = .Range("A" & Rows.Count).End(xlUp).Row
        .Range("A13:A" & Er).HorizontalAlignment = xlCenter
        .Range("C13:C" & Er).HorizontalAlignment = xlLeft
        Union(.Range("B13:B" & Er), .Range("E13:F" & Er)).HorizontalAlignment = xlRight
        .Range("E13:F" & Er).NumberFormat = "#,##0"
        .Range("C" & Er + 1) = .Range("J4")
        .Range("E" & Er + 1) = "=Sum(E13:E" & Er & ")"
        .Range("F" & Er + 1) = "=Sum(F13:F" & Er & ")"
        With .Range("A" & Er + 1 & ": F" & Er + 1)
            .Borders.LineStyle = xlContinuous
            .Font.Bold = True
        End With
        .Range("D" & Er + 3) = .Range("J3")
        .Range("A" & Er + 4) = .Range("J2"):  .Range("A" & Er + 9) = .Range("J5")
        .Range("D" & Er + 4) = .Range("J4"):  .Range("D" & Er + 9) = .Range("J6")
        .Range("A" & Er + 4 & ": C" & Er + 9).HorizontalAlignment = xlCenterAcrossSelection
        .Range("D" & Er + 3 & ": F" & Er + 9).HorizontalAlignment = xlCenterAcrossSelection
        ActiveSheet.PageSetup.PrintArea = "$A$1:$F" & Er + 9
    End If
End With
End Sub
Bài đã được tự động gộp:

Hongha0412 đã viết:
Code chạy ok quá. Mà giờ muốn đổi cái font chữ sang times new roman thì sửa chỗ nào vậy bạn.
Nhấp chuột vào đây để mở rộng...
bạn thử code này
Mã: 
Sub InSoCai()
    Dim sArr(), dArr(), I As Long, J As Long
    Dim SoTK As Long, TKno As Long, TKco As Long, Er As Long
SoTK = Sheets("So").Range("D4").Value
With Sheets("T01")
    Er = .Range("D" & Rows.Count).End(xlUp).Row
    If Er < 7 Then Exit Sub
    sArr = .Range("D7:D" & Er).Resize(, 7).Value
End With
ReDim dArr(1 To UBound(sArr), 1 To 6)
For I = 1 To UBound(sArr)
    If sArr(I, 5) <> Empty Then TKno = Left(sArr(I, 5), 3)
    If sArr(I, 6) <> Empty Then TKco = Left(sArr(I, 6), 3)
    If TKno = SoTK Or TKco = SoTK Then
        K = K + 1
        For J = 1 To 4
            dArr(K, J) = sArr(I, J)
        Next J
        If TKno = SoTK Then dArr(K, 5) = sArr(I, 7)
        If TKco = SoTK Then dArr(K, 6) = sArr(I, 7)
    End If
Next I
With Sheets("So")
    .Range("A13:F5000").Clear
    If K Then
        With .Range("A13").Resize(K, 6)
            .Value = dArr
            .Borders.LineStyle = xlContinuous
            .Borders(xlInsideHorizontal).Weight = xlHairline
        End With
        Er = .Range("A" & Rows.Count).End(xlUp).Row
        .Range("A13:A" & Er).HorizontalAlignment = xlCenter
        .Range("C13:C" & Er).HorizontalAlignment = xlLeft
        Union(.Range("B13:B" & Er), .Range("E13:F" & Er)).HorizontalAlignment = xlRight
        .Range("E13:F" & Er).NumberFormat = "#,##0"
        .Range("C" & Er + 1) = .Range("J4")
        .Range("E" & Er + 1) = "=Sum(E13:E" & Er & ")"
        .Range("F" & Er + 1) = "=Sum(F13:F" & Er & ")"
        With .Range("A" & Er + 1 & ": F" & Er + 1)
            .Borders.LineStyle = xlContinuous
            .Font.Bold = True
        End With
        .Range("D" & Er + 3) = .Range("J3")
        .Range("A" & Er + 4) = .Range("J2"):  .Range("A" & Er + 9) = .Range("J5")
        .Range("D" & Er + 4) = .Range("J4"):  .Range("D" & Er + 9) = .Range("J6")
        .Range("A" & Er + 4 & ": C" & Er + 9).HorizontalAlignment = xlCenterAcrossSelection
        .Range("D" & Er + 3 & ": F" & Er + 9).HorizontalAlignment = xlCenterAcrossSelection
        ActiveSheet.PageSetup.PrintArea = "$A$1:$F" & Er + 9
    End If
End With
End Sub
 
Upvote 0
Hongha0412 đã viết:
Code chạy ok quá. Mà giờ muốn đổi cái font chữ sang times new roman thì sửa chỗ nào vậy bạn.
Nhấp chuột vào đây để mở rộng...
Bạn thêm dòng
Mã: 
  .Range("A13: F" & Er + 9).Font.Name = "Times New Roman"
vào trước dòng
Mã: 
ActiveSheet.PageSetup.PrintArea = "$A$1:$F" & Er + 9
 
Upvote 0
Hongha0412 đã viết:
Code chạy ok quá. Mà giờ muốn đổi cái font chữ sang times new roman thì sửa chỗ nào vậy bạn.
Nhấp chuột vào đây để mở rộng...

Mã: 
You add row

  .Range("A13: F" & Er + 9).Font.Name = "Times New Roman"

in front of the line

ActiveSheet.PageSetup.PrintArea = "$A$1:$F" & Er + 9
 
Upvote 0
congnguyen88 đã viết:
Mã: 
You add row

  .Range("A13: F" & Er + 9).Font.Name = "Times New Roman"

in front of the line

ActiveSheet.PageSetup.PrintArea = "$A$1:$F" & Er + 9
Nhấp chuột vào đây để mở rộng...
before, NOT "in front of"
in front means:
.Range("A13: F" & Er + 9).Font.Name = "Times New Roman" ActiveSheet.PageSetup.PrintArea = "$A$1:$F" & Er + 9
And,
"You add row" is rather rude, and grammatically incorrect.
"Add the following line" would be more appropriate.
 
Upvote 0
VetMini đã viết:
before, NOT "in front of"
in front means:
.Range("A13: F" & Er + 9).Font.Name = "Times New Roman" ActiveSheet.PageSetup.PrintArea = "$A$1:$F" & Er + 9
And,
"You add row" is rather rude, and grammatically incorrect.
"Add the following line" would be more appropriate.
Nhấp chuột vào đây để mở rộng...
OK I understand. because I'm using google translate. Responsible then google
 
Upvote 0
Lần chỉnh sửa cuối:
Upvote 0
PacificPR đã viết:
Trời đất ạ. Người Việt Nam nói chuyện với người Việt Nam lại nhờ google translate từ tiếng Việt sang tiếng Anh.
Hậu quả bị mắng là xứng đáng rồi
Nhấp chuột vào đây để mở rộng...

I'm happy to make the story humorous. I'm sorry teacher. Hope the teacher forgive me hihi
 
Upvote 0
Tôi chỉ chỉnh sửa cho các bạn khác biết thôi. Không thấy gì trào lộng trong tiếng Anh sai ngữ pháp cả.
Nếu trào lộng thì nó phải thật cố tình sai, để người khác biết, ví dụ:
You increase row
Enter before row
 
Upvote 0
Bạn phải đăng nhập hoặc đăng ký để trả lời bài viết tại đây.
Web KT

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

SA_DQ
  • Question Question
[Bài tập VBA cho người rỗi rảnh] Hãy viết 1 macro tìm ra 3 số nguyên tố liên tiếp
2
Trả lời
27
Đọc
517
VetMini
V
T
Định dạng cột dữ liệu trong sql
Trả lời
0
Đọc
28
tuanxitin
T
L
  • Question Question
[Hlep] Xóa ảnh theo tên và kích thước
Trả lời
8
Đọc
157
Luong24
L
Xoainon3005
Xin file mẫu kế hoạch sản xuất theo tháng ngành động cơ
Trả lời
0
Đọc
51
Xoainon3005
Xoainon3005
A
Tạo vé Loto bằng Excel
Trả lời
19
Đọc
23K
vinhquang14292
vinhquang14292
ongke0711
  • Question Question
Tải hóa đơn điện tử (https://hoadondientu.gdt.gov.vn/) Excel Vba
    • Thích
    • Yêu thích
    • Cảm ơn
14 15 16
Trả lời
308
Đọc
22K
CheezeTube
CheezeTube
Akingee
Món quà tuyệt vời thứ 2 của Cloudflare dành cho nhân loại - WARP
Trả lời
0
Đọc
79
Akingee
Akingee
HeSanbi
  • Đã giải quyết
LocalizeXL v1.73 - Làm nổi bật ô đang chọn và cuộn trang tự động
    • Thích
    • Yêu thích
2 3 4
Trả lời
74
Đọc
10K
vn72259
V
H
Vì sao trong khi cộng và khi sum lại hiển thị sai
Trả lời
15
Đọc
57K
hieung99
hieung99
Thanh271188
Tìm giá trị xuất hiện bất kì (không phải giá trị đầu, cuối) trong excel
    • Cười
Trả lời
3
Đọc
138
VetMini
V
T
Nhờ hỗ trợ hàm SUMIF không phân biệt được các ký tự "0" trước một số trong chuỗi
Trả lời
3
Đọc
187
tan10ckn
T
huuthang_bd
Add-in DeleteVirusMacro - Xóa và ngăn chặn virus macro
    • Thích
    • Yêu thích
    • Chấp nhận
2 3
Trả lời
46
Đọc
14K
tuantran203
T
ongke0711
  • Question Question
Trộn dữ liệu từ Excel sang Word mở rộng (phiên bản ongke0711)
    • Thích
    • Yêu thích
    • Cảm ơn
12 13 14
Trả lời
260
Đọc
27K
hoangtuan.net
hoangtuan.net
HeSanbi
  • Đã giải quyết
WeatherXL - Ứng dụng lấy dữ liệu Thời tiết siêu nhanh (*15/01/2024)
    • Thích
    • Yêu thích
3 4 5
Trả lời
88
Đọc
19K
vc_đi chơi
vc_đi chơi
L
[Help] tự động lấy dữ liệu cổ phiếu từ vietstock về file excel
    • Thích
Trả lời
3
Đọc
844
ketoan113
K
N
Tách chuỗi và tìm kiếm theo dữ liệu gần đúng trong chuỗi ký tự
Trả lời
8
Đọc
203
Ngocminh19
N
Mr.hieudoanxd
  • Question Question
[Cần hướng dẫn] Về lập trình Viết Function với Settimer và Killtimer
    • Thích
Trả lời
8
Đọc
346
nguyendang95
N
P
Các Bác cho e hỏi làm thế nào để ẩn công thức trên GOOGLE SHEET với ạ?
2
Trả lời
21
Đọc
18K
học excel googlesheet
học excel googlesheet
Emyeuexcel
  • Question Question
Code VBA mở nhiều file, value các sheet, lưu và đóng file
Trả lời
3
Đọc
146
Emyeuexcel
Emyeuexcel
V
Cho 2 biến - kết quả trả về giá trị của hàng đầu tiên
    • Chấp nhận
Trả lời
5
Đọc
179
Duy Tùng 9x
Duy Tùng 9x
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

Đếm ngược thời gian

000
Ngày
00
Giờ
00
phút
00
giây
Chúc mừng năm mới Ất Tỵ 2025
Back
Top Bottom