Xin Hỗ trợ Code VBA (1 người xem)

duyet_vbatg · 23/5/17

Xin Anh Chị diễn đàn hỗ trợ mình code vba tính tổng của 3 ô trong 3 file excel khác nhau vào một ô trong 1 file excel khác có file ví dụ đính kèm
Xin cảm ơn nhiều !

phulien1902 · 24/5/17

duyet_vbatg đã viết:
Xin Anh Chị diễn đàn hỗ trợ mình code vba tính tổng của 3 ô trong 3 file excel khác nhau vào một ô trong 1 file excel khác có file ví dụ đính kèm
Xin cảm ơn nhiều !

Bạn thử với:

PHP:

Option Explicit
Sub Update_abc()
    Dim vFile As Variant, i As Integer, sWB As String, rRng As Range, Sh As Worksheet
    vFile = Application.GetOpenFilename _
            (FileFilter:="Excel Files, *.xls*", _
             Title:="Xin moi chon File o day", _
             MultiSelect:=True)
    If Not IsArray(vFile) Then
        MsgBox "Ban da khong chon File nao?", vbExclamation
        Exit Sub
    End If
    Application.ScreenUpdating = False
    For i = LBound(vFile) To UBound(vFile)
        Workbooks.Open Filename:=vFile(i)
        sWB = ActiveWorkbook.Name
        If i = 1 Then
            Set rRng = Range("A1:B100")
        Else
            Set rRng = Range("A1:B100").Offset(1)
        End If
        rRng.Copy ThisWorkbook.Sheets("TH").Range("A" & Rows.Count).End(xlUp).Offset(1)
        Workbooks(sWB).Close False
    Next i
    ActiveSheet.AutoFilterMode = False
    Application.ScreenUpdating = True
    Rows("2:2").ClearContents
    If MsgBox("Ban muon tong hop du lieu?", vbYesNo, "Thong bao") = vbNo Then
        Exit Sub
    Else
        Call Consolidation_abc
    End If
    Rows("1:1").Resize(, 2) = Array("STT", "LOAI")
End Sub
Sub Consolidation_abc()
    Dim a, i%
    a = Range("A2:B29").Value
    With CreateObject("Scripting.Dictionary")
        .CompareMode = 1
        For i = 1 To UBound(a, 1)
            If Not .exists(a(i, 1)) Then
                .Item(a(i, 1)) = a(i, 2)
            Else
                .Item(a(i, 1)) = .Item(a(i, 1)) + a(i, 2)
            End If
        Next
        If .Count Then
            Range("A1:B1000").ClearContents
            Range("A1").Resize(.Count, 2).Value = Application.Transpose(Array(.Keys, .Items))
        End If
    End With
End Sub

Hoang2013 · 24/5/17

Rút kinh nghiệm cho những lần sau:

Tiêu đề bài viết nên là:
"Xin hỗ trợ code vba tính tổng của 3 ô trong 3 file excel khác nhau"

duyet_vbatg · 24/5/17

Ok. sẽ rút kinh nghiệm lần sau
cám ơn bạn nhiều !

duyet_vbatg · 24/5/17

phulien1902 đã viết:

Bạn thử với:

PHP:

Option Explicit
Sub Update_abc()
    Dim vFile As Variant, i As Integer, sWB As String, rRng As Range, Sh As Worksheet
    vFile = Application.GetOpenFilename _
            (FileFilter:="Excel Files, *.xls*", _
             Title:="Xin moi chon File o day", _
             MultiSelect:=True)
    If Not IsArray(vFile) Then
        MsgBox "Ban da khong chon File nao?", vbExclamation
        Exit Sub
    End If
    Application.ScreenUpdating = False
    For i = LBound(vFile) To UBound(vFile)
        Workbooks.Open Filename:=vFile(i)
        sWB = ActiveWorkbook.Name
        If i = 1 Then
            Set rRng = Range("A1:B100")
        Else
            Set rRng = Range("A1:B100").Offset(1)
        End If
        rRng.Copy ThisWorkbook.Sheets("TH").Range("A" & Rows.Count).End(xlUp).Offset(1)
        Workbooks(sWB).Close False
    Next i
    ActiveSheet.AutoFilterMode = False
    Application.ScreenUpdating = True
    Rows("2:2").ClearContents
    If MsgBox("Ban muon tong hop du lieu?", vbYesNo, "Thong bao") = vbNo Then
        Exit Sub
    Else
        Call Consolidation_abc
    End If
    Rows("1:1").Resize(, 2) = Array("STT", "LOAI")
End Sub
Sub Consolidation_abc()
    Dim a, i%
    a = Range("A2:B29").Value
    With CreateObject("Scripting.Dictionary")
        .CompareMode = 1
        For i = 1 To UBound(a, 1)
            If Not .exists(a(i, 1)) Then
                .Item(a(i, 1)) = a(i, 2)
            Else
                .Item(a(i, 1)) = .Item(a(i, 1)) + a(i, 2)
            End If
        Next
        If .Count Then
            Range("A1:B1000").ClearContents
            Range("A1").Resize(.Count, 2).Value = Application.Transpose(Array(.Keys, .Items))
        End If
    End With
End Sub

Cám ơn Phulien1902 rất nhiều. mình sẽ thử xem nó chạy đúng không nhé

hoan80 · 25/5/17

Xin các Anh, Chị trong diễn đàn sửa giúp code vba để lọc 1 số chứng từ có thể đến 65.000 dòng, lọc 1 số tài khoản có thể lên đến 65.000 dòng với ạ. Tức là khi thêm dòng bên sheet PHATSINH lên tới 65.000 dòng thì các sheet bên (CTGS, socai, DKCTGS) cũng lọc lên 65.000 dòng ạ, (các dòng tổng cộng và người lập, ký dưới cùng vẫn giữ nguyên).
Xin cảm ơn các anh, chị nhiều>

phulien1902 · 25/5/17

hoan80 đã viết:
Xin các Anh, Chị trong diễn đàn sửa giúp code vba để lọc 1 số chứng từ có thể đến 65.000 dòng, lọc 1 số tài khoản có thể lên đến 65.000 dòng với ạ. Tức là khi thêm dòng bên sheet PHATSINH lên tới 65.000 dòng thì các sheet bên (CTGS, socai, DKCTGS) cũng lọc lên 65.000 dòng ạ, (các dòng tổng cộng và người lập, ký dưới cùng vẫn giữ nguyên).
Xin cảm ơn các anh, chị nhiều>

Bạn hãy lập 1 topic mới để các thành viên trợ giúp.

hoan80 · 25/5/17

phulien1902 đã viết:
Bạn hãy lập 1 topic mới để các thành viên trợ giúp.

Cảm ơn phulien1902 nhiều

HieuCD · 25/5/17

hoan80 đã viết:
Xin các Anh, Chị trong diễn đàn sửa giúp code vba để lọc 1 số chứng từ có thể đến 65.000 dòng, lọc 1 số tài khoản có thể lên đến 65.000 dòng với ạ. Tức là khi thêm dòng bên sheet PHATSINH lên tới 65.000 dòng thì các sheet bên (CTGS, socai, DKCTGS) cũng lọc lên 65.000 dòng ạ, (các dòng tổng cộng và người lập, ký dưới cùng vẫn giữ nguyên).
Xin cảm ơn các anh, chị nhiều>

lỡ làm nên gởi luôn, lần sau mở topic mới
dùng code sau để tăng tốc xử lý

Mã:

Public Sub S_CTGS()
Dim sArr(), dArr(), Rng As Range, I As Long, K As Long, R As Long, Num As Long
With Sheets("CTGS")
  .Rows("10:31").Hidden = False
  .Range("A10:E31").ClearContents
  Num = .Range("C4").Value
End With
With Sheets("PHATSINH")
  R = .Range("C" & Rows.Count).End(xlUp).Row
  If R < 15 Then MsgBox ("Khong co du lieu phat sinh"): Exit Sub
  Set Rng = .Range("B15:B" & R).Find(Num, LookIn:=xlValues, Lookat:=xlWhole)
  If Not Rng Is Nothing Then
    sArr = .Range("C" & Rng.Row, .Range("H" & R)).Value
  Else
    Sheets("CTGS").Rows("10:30").Hidden = True
    MsgBox ("Chung tu ghi so so: " & Num & "   khong tim thay")
    Exit Sub
  End If
End With
ReDim dArr(1 To UBound(sArr), 1 To 4)
For I = 1 To UBound(sArr)
  If sArr(I, 1) = Num Then
    K = K + 1
    dArr(K, 1) = sArr(I, 3):     dArr(K, 2) = sArr(I, 4)
    dArr(K, 3) = sArr(I, 5):     dArr(K, 4) = sArr(I, 6)
  Else
    Exit For
  End If
Next I
With Sheets("CTGS")
  If K Then
    .Range("C5") = sArr(K, 2)
    .Range("A10:D10").Resize(K) = dArr
    .Rows(K + 10 & ":31").Hidden = True
  End If
End With
End Sub

hoan80 · 25/5/17

HieuCD đã viết:

lỡ làm nên gởi luôn, lần sau mở topic mới
dùng code sau để tăng tốc xử lý

Mã:

Public Sub S_CTGS()
Dim sArr(), dArr(), Rng As Range, I As Long, K As Long, R As Long, Num As Long
With Sheets("CTGS")
  .Rows("10:31").Hidden = False
  .Range("A10:E31").ClearContents
  Num = .Range("C4").Value
End With
With Sheets("PHATSINH")
  R = .Range("C" & Rows.Count).End(xlUp).Row
  If R < 15 Then MsgBox ("Khong co du lieu phat sinh"): Exit Sub
  Set Rng = .Range("B15:B" & R).Find(Num, LookIn:=xlValues, Lookat:=xlWhole)
  If Not Rng Is Nothing Then
    sArr = .Range("C" & Rng.Row, .Range("H" & R)).Value
  Else
    Sheets("CTGS").Rows("10:30").Hidden = True
    MsgBox ("Chung tu ghi so so: " & Num & "   khong tim thay")
    Exit Sub
  End If
End With
ReDim dArr(1 To UBound(sArr), 1 To 4)
For I = 1 To UBound(sArr)
  If sArr(I, 1) = Num Then
    K = K + 1
    dArr(K, 1) = sArr(I, 3):     dArr(K, 2) = sArr(I, 4)
    dArr(K, 3) = sArr(I, 5):     dArr(K, 4) = sArr(I, 6)
  Else
    Exit For
  End If
Next I
With Sheets("CTGS")
  If K Then
    .Range("C5") = sArr(K, 2)
    .Range("A10:D10").Resize(K) = dArr
    .Rows(K + 10 & ":31").Hidden = True
  End If
End With
End Sub

Cảm ơn anh HieuCD nhiều ạ, em thay code code của anh vào code cũ thì không chạy các sheet socai và sheet DKCTGS ạ. code cũ ở đây chạy hết các sheet tốt mà chỉ giới hạn ở sheet PHATSINH đến dòng 1090 thôi ạ, chính vậy nên khi em chèn thêm dòng (đến 65.000 chẳng hạn) thì các sheet bên phải sheet PHATSINH không lọc được. Nhờ anh xem lại và chỉnh giúp em với?
Cảm ơn anh HieuCD nhiều ạ.

HieuCD · 25/5/17

hoan80 đã viết:
Cảm ơn anh HieuCD nhiều ạ, em thay code code của anh vào code cũ thì không chạy các sheet socai và sheet DKCTGS ạ. code cũ ở đây chạy hết các sheet tốt mà chỉ giới hạn ở sheet PHATSINH đến dòng 1090 thôi ạ, chính vậy nên khi em chèn thêm dòng (đến 65.000 chẳng hạn) thì các sheet bên phải sheet PHATSINH không lọc được. Nhờ anh xem lại và chỉnh giúp em với?
Cảm ơn anh HieuCD nhiều ạ.

file của bạn gởi lên có một số vấn đề:
1/ chỉ có mấy sheet và vài trăm dòng mà kích thước hơn 3M là quá lớn nếu đủ các sheet khác và các dòng dữ liệu thì chạy rất chậm: thiết kế không hiệu quả
2/ Vừa dùng code vừa dùng công thức trong một sheet như dòng tổng cộng là không ổn, dùng chức năng Hide dòng tương đối đơn giản nhưng file sẽ nặng và bị giới hạn dòng dữ liệu
3/ nếu bạn tạo sổ cái quí 2 thì số dư đầu kỳ tính như thế nào, số đầu kỳ bảng CDPS sẽ như thế nào
4/ kế toán bằng Excel nên hạn chế trang trí màu mè làm tăng kích thước file
chỉ góp ý nhỏ, code thì bạn Ba tê đã giúp

hoan80 · 25/5/17

HieuCD đã viết:
file của bạn gởi lên có một số vấn đề:
1/ chỉ có mấy sheet và vài trăm dòng mà kích thước hơn 3M là quá lớn nếu đủ các sheet khác và các dòng dữ liệu thì chạy rất chậm: thiết kế không hiệu quả
2/ Vừa dùng code vừa dùng công thức trong một sheet như dòng tổng cộng là không ổn, dùng chức năng Hide dòng tương đối đơn giản nhưng file sẽ nặng và bị giới hạn dòng dữ liệu
3/ nếu bạn tạo sổ cái quí 2 thì số dư đầu kỳ tính như thế nào, số đầu kỳ bảng CDPS sẽ như thế nào
4/ kế toán bằng Excel nên hạn chế trang trí màu mè làm tăng kích thước file
chỉ góp ý nhỏ, code thì bạn Ba tê đã giúp

Dạ, xin đa tạ các anh, nhất là anh Ba Tê và anh ạ.

duyet_vbatg · 25/5/17

phulien1902 đã viết:

Bạn thử với:

PHP:

Option Explicit
Sub Update_abc()
    Dim vFile As Variant, i As Integer, sWB As String, rRng As Range, Sh As Worksheet
    vFile = Application.GetOpenFilename _
            (FileFilter:="Excel Files, *.xls*", _
             Title:="Xin moi chon File o day", _
             MultiSelect:=True)
    If Not IsArray(vFile) Then
        MsgBox "Ban da khong chon File nao?", vbExclamation
        Exit Sub
    End If
    Application.ScreenUpdating = False
    For i = LBound(vFile) To UBound(vFile)
        Workbooks.Open Filename:=vFile(i)
        sWB = ActiveWorkbook.Name
        If i = 1 Then
            Set rRng = Range("A1:B100")
        Else
            Set rRng = Range("A1:B100").Offset(1)
        End If
        rRng.Copy ThisWorkbook.Sheets("TH").Range("A" & Rows.Count).End(xlUp).Offset(1)
        Workbooks(sWB).Close False
    Next i
    ActiveSheet.AutoFilterMode = False
    Application.ScreenUpdating = True
    Rows("2:2").ClearContents
    If MsgBox("Ban muon tong hop du lieu?", vbYesNo, "Thong bao") = vbNo Then
        Exit Sub
    Else
        Call Consolidation_abc
    End If
    Rows("1:1").Resize(, 2) = Array("STT", "LOAI")
End Sub
Sub Consolidation_abc()
    Dim a, i%
    a = Range("A2:B29").Value
    With CreateObject("Scripting.Dictionary")
        .CompareMode = 1
        For i = 1 To UBound(a, 1)
            If Not .exists(a(i, 1)) Then
                .Item(a(i, 1)) = a(i, 2)
            Else
                .Item(a(i, 1)) = .Item(a(i, 1)) + a(i, 2)
            End If
        Next
        If .Count Then
            Range("A1:B1000").ClearContents
            Range("A1").Resize(.Count, 2).Value = Application.Transpose(Array(.Keys, .Items))
        End If
    End With
End Sub

Bạn Phulien1902 code chạy báo lỗi như sau: Run time error '9': subscript out of range
Xin bạn giúp đỡ. cám ơn nhiều

Hai Lúa Miền Tây · 25/5/17

duyet_vbatg đã viết:
Xin Anh Chị diễn đàn hỗ trợ mình code vba tính tổng của 3 ô trong 3 file excel khác nhau vào một ô trong 1 file excel khác có file ví dụ đính kèm
Xin cảm ơn nhiều !

Bài này có thể giải quyết = ADO?

duyet_vbatg · 26/5/17

Hai Lúa Miền Tây đã viết:
Bài này có thể giải quyết = ADO?

không bạn ơi

Xin Hỗ trợ Code VBA (1 người xem)

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

duyet_vbatg

Thành viên mới

File đính kèm

phulien1902

GPE - My love

File đính kèm

Hoang2013

Thành viên gắn bó

duyet_vbatg

Thành viên mới

duyet_vbatg

Thành viên mới

hoan80

Thành viên mới

File đính kèm

phulien1902

GPE - My love

hoan80

Thành viên mới

HieuCD

Chuyên gia GPE

hoan80

Thành viên mới

HieuCD

Chuyên gia GPE

hoan80

Thành viên mới

duyet_vbatg

Thành viên mới

Hai Lúa Miền Tây

❆❆❆❆❆❆❆❆

duyet_vbatg

Thành viên mới

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

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

Sinh nhật lần 19 GPE