Giúp em Công thức Coppy bằng VBA

Liên hệ QC
H

happyghost2000

Thành viên chính thức
Tham gia
24/5/08
Bài viết
70
Được thích
6
Nhờ Anh, Chị giúp dùm .
Mình có 2 File Text : Suiko17-1 , Suiko17-5
Mình có file Excel tổng họp : là dữ liệu coppy từ 2 file Text trên .
Mình muốn có đoạn code để nó tự coppy dữ lliệu qua
Yều cầu là các dòng trùng nhau thì cộng lại số lượng ( cột F đến cột U )
Mong Anh, Chị giúp dùm .
Bài đã được tự động gộp:

Mong Anh, Chị giúp dùm em .
 

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
LamNA đã viết:
Tiếp sức tý nữa coi như cũng được 75% giải hết ra vì sức có hạn
Đoạn này coi như đã lấy được dự liệu trong file .txt
Mã: 
Sub NhapFile_TXT()
Dim Index As Long, n As Long, col As Long, row As Long, Text As String
Dim Rng As Range, FSO As Object, FilesToImport
Dim TextSource As Object, NumOfLines, Cols, Res()
Sheets("ONVSUIK").Range("A2:U65536").ClearContents
Set Rng = Sheets("ONVSUIK").Range("A2")
FilesToImport = Application.GetOpenFilename("Text Files (*.txt), *.txt", , , , True)
If IsArray(FilesToImport) Then
    Set FSO = CreateObject("Scripting.FileSystemObject")
    For Index = 1 To UBound(FilesToImport)
        n = 0
        Set TextSource = FSO.OpenTextFile(FilesToImport(Index), 1, , -2)
        NumOfLines = Split(TextSource.ReadAll, vbCrLf)
       
        If UBound(NumOfLines) > 0 Then
            ReDim Res(1 To UBound(NumOfLines), 1 To 1)
            For row = 1 To UBound(NumOfLines)
                Text = NumOfLines(row)
                If Text <> "" Then
                    If Text <> String(Len(Text), ",") Then
                        n = n + 1
                        Cols = Split(Text, ",")
                        If UBound(Res, 2) < UBound(Cols) + 1 Then
                            ReDim Preserve Res(1 To UBound(NumOfLines), 1 To UBound(Cols) + 1)
                        End If
                        For col = 1 To UBound(Res, 2)
                            Res(n, col) = Replace(Cols(col - 1), """", "")
                        Next
                    End If
                End If
            Next
        End If
        Rng.Resize(n, UBound(Res, 2)).Value = Res
        Set Rng = Rng.Offset(n)
    Next
End If
'-----------------------------------------
'goi sub để loc trùng"
Call Loc
'-----------------------------------------
End Sub

Tiếp theo sẽ lọc trùng nhưng code này chỉ lọc trùng 1 cột (a) chưa phải là 3 cột (b,c,d), tạm thời chưa tìm ra giải pháp bạn chờ anh chị khác hỗ trợ thêm cho bạn nhé

Mã: 
Sub Loc()
    Dim Dic As Object
    Dim i As Long, j As Long, k As Long
    Dim Tmp As String
    Dim Arr, dArr
    Application.ScreenUpdating = False
    Arr = Range(Sheet1.[A2], Sheet1.[U60000].End(3)).Resize(, 21)
    ReDim dArr(1 To UBound(Arr, 1), 1 To UBound(Arr, 2))
    Set Dic = CreateObject("Scripting.Dictionary")
    With Dic
        For i = 1 To UBound(Arr, 1)
             Tmp = Arr(i, 2)
            If Not .Exists(Tmp) Then
                k = k + 1
                .Add Tmp, k
                For j = 1 To UBound(Arr, 2)
                    dArr(k, j) = Arr(i, j)
                Next j
            Else
                dArr(.Item(Tmp), 6) = dArr(.Item(Tmp), 6) + Arr(i, 6)
                dArr(.Item(Tmp), 7) = dArr(.Item(Tmp), 7) + Arr(i, 7)
                dArr(.Item(Tmp), 8) = dArr(.Item(Tmp), 8) + Arr(i, 8)
                dArr(.Item(Tmp), 9) = dArr(.Item(Tmp), 9) + Arr(i, 9)
                dArr(.Item(Tmp), 10) = dArr(.Item(Tmp), 10) + Arr(i, 10)
                dArr(.Item(Tmp), 11) = dArr(.Item(Tmp), 11) + Arr(i, 11)
                dArr(.Item(Tmp), 12) = dArr(.Item(Tmp), 12) + Arr(i, 12)
                dArr(.Item(Tmp), 13) = dArr(.Item(Tmp), 13) + Arr(i, 13)
                dArr(.Item(Tmp), 14) = dArr(.Item(Tmp), 14) + Arr(i, 14)
                dArr(.Item(Tmp), 15) = dArr(.Item(Tmp), 15) + Arr(i, 15)
                dArr(.Item(Tmp), 16) = dArr(.Item(Tmp), 16) + Arr(i, 16)
                dArr(.Item(Tmp), 17) = dArr(.Item(Tmp), 17) + Arr(i, 17)
                dArr(.Item(Tmp), 18) = dArr(.Item(Tmp), 18) + Arr(i, 18)
                dArr(.Item(Tmp), 19) = dArr(.Item(Tmp), 19) + Arr(i, 19)
                dArr(.Item(Tmp), 20) = dArr(.Item(Tmp), 20) + Arr(i, 20)
                dArr(.Item(Tmp), 21) = dArr(.Item(Tmp), 21) + Arr(i, 21)
            End If
        Next i
    End With
    Sheet1.Range("A2").Resize(1000, 21).ClearContents
    Sheet1.Range("A2").Resize(k, UBound(Arr, 2)) = dArr
    Application.ScreenUpdating = True
End Sub
Nhấp chuột vào đây để mở rộng...
Lọc trùng nhiều cột: tmp= Arr(i, 2) &"#" &Arr(i, 3) &"#" ....
 
Upvote 0
HieuCD đã viết:
Lọc trùng nhiều cột: tmp= Arr(i, 2) &"#" &Arr(i, 3) &"#" ....
Nhấp chuột vào đây để mở rộng...
Em nhớ có hỏi anh 1 lần về cái này mà áp dụng còn bỡ ngỡ
Bài đã được tự động gộp:

LamNA đã viết:
Tiếp sức tý nữa coi như cũng được 75% giải hết ra vì sức có hạn
Đoạn này coi như đã lấy được dự liệu trong file .txt
Mã: 
Sub NhapFile_TXT()
Dim Index As Long, n As Long, col As Long, row As Long, Text As String
Dim Rng As Range, FSO As Object, FilesToImport
Dim TextSource As Object, NumOfLines, Cols, Res()
Sheets("ONVSUIK").Range("A2:U65536").ClearContents
Set Rng = Sheets("ONVSUIK").Range("A2")
FilesToImport = Application.GetOpenFilename("Text Files (*.txt), *.txt", , , , True)
If IsArray(FilesToImport) Then
    Set FSO = CreateObject("Scripting.FileSystemObject")
    For Index = 1 To UBound(FilesToImport)
        n = 0
        Set TextSource = FSO.OpenTextFile(FilesToImport(Index), 1, , -2)
        NumOfLines = Split(TextSource.ReadAll, vbCrLf)
       
        If UBound(NumOfLines) > 0 Then
            ReDim Res(1 To UBound(NumOfLines), 1 To 1)
            For row = 1 To UBound(NumOfLines)
                Text = NumOfLines(row)
                If Text <> "" Then
                    If Text <> String(Len(Text), ",") Then
                        n = n + 1
                        Cols = Split(Text, ",")
                        If UBound(Res, 2) < UBound(Cols) + 1 Then
                            ReDim Preserve Res(1 To UBound(NumOfLines), 1 To UBound(Cols) + 1)
                        End If
                        For col = 1 To UBound(Res, 2)
                            Res(n, col) = Replace(Cols(col - 1), """", "")
                        Next
                    End If
                End If
            Next
        End If
        Rng.Resize(n, UBound(Res, 2)).Value = Res
        Set Rng = Rng.Offset(n)
    Next
End If
'-----------------------------------------
'goi sub để loc trùng"
Call Loc
'-----------------------------------------
End Sub

Tiếp theo sẽ lọc trùng nhưng code này chỉ lọc trùng 1 cột (a) chưa phải là 3 cột (b,c,d), tạm thời chưa tìm ra giải pháp bạn chờ anh chị khác hỗ trợ thêm cho bạn nhé

Mã: 
Sub Loc()
    Dim Dic As Object
    Dim i As Long, j As Long, k As Long
    Dim Tmp As String
    Dim Arr, dArr
    Application.ScreenUpdating = False
    Arr = Range(Sheet1.[A2], Sheet1.[U60000].End(3)).Resize(, 21)
    ReDim dArr(1 To UBound(Arr, 1), 1 To UBound(Arr, 2))
    Set Dic = CreateObject("Scripting.Dictionary")
    With Dic
        For i = 1 To UBound(Arr, 1)
             Tmp = Arr(i, 2)
            If Not .Exists(Tmp) Then
                k = k + 1
                .Add Tmp, k
                For j = 1 To UBound(Arr, 2)
                    dArr(k, j) = Arr(i, j)
                Next j
            Else
                dArr(.Item(Tmp), 6) = dArr(.Item(Tmp), 6) + Arr(i, 6)
                dArr(.Item(Tmp), 7) = dArr(.Item(Tmp), 7) + Arr(i, 7)
                dArr(.Item(Tmp), 8) = dArr(.Item(Tmp), 8) + Arr(i, 8)
                dArr(.Item(Tmp), 9) = dArr(.Item(Tmp), 9) + Arr(i, 9)
                dArr(.Item(Tmp), 10) = dArr(.Item(Tmp), 10) + Arr(i, 10)
                dArr(.Item(Tmp), 11) = dArr(.Item(Tmp), 11) + Arr(i, 11)
                dArr(.Item(Tmp), 12) = dArr(.Item(Tmp), 12) + Arr(i, 12)
                dArr(.Item(Tmp), 13) = dArr(.Item(Tmp), 13) + Arr(i, 13)
                dArr(.Item(Tmp), 14) = dArr(.Item(Tmp), 14) + Arr(i, 14)
                dArr(.Item(Tmp), 15) = dArr(.Item(Tmp), 15) + Arr(i, 15)
                dArr(.Item(Tmp), 16) = dArr(.Item(Tmp), 16) + Arr(i, 16)
                dArr(.Item(Tmp), 17) = dArr(.Item(Tmp), 17) + Arr(i, 17)
                dArr(.Item(Tmp), 18) = dArr(.Item(Tmp), 18) + Arr(i, 18)
                dArr(.Item(Tmp), 19) = dArr(.Item(Tmp), 19) + Arr(i, 19)
                dArr(.Item(Tmp), 20) = dArr(.Item(Tmp), 20) + Arr(i, 20)
                dArr(.Item(Tmp), 21) = dArr(.Item(Tmp), 21) + Arr(i, 21)
            End If
        Next i
    End With
    Sheet1.Range("A2").Resize(1000, 21).ClearContents
    Sheet1.Range("A2").Resize(k, UBound(Arr, 2)) = dArr
    Application.ScreenUpdating = True
End Sub
Nhấp chuột vào đây để mở rộng...
Theo gợi ý của bác @HieuCD , em gom 2 sub thành một cho anh đã lọc trùng và tính tổng, anh kiểm tra xem có sai xót gì không nhé

Mã: 
Sub NhapFile_TXT_LocTrung()
Dim Index As Long, n As Long, col As Long, row As Long, Text As String
Dim Rng As Range, FSO As Object, FilesToImport
Dim TextSource As Object, NumOfLines, Cols, Res()
Dim Dic As Object
    Dim i As Long, j As Long, k As Long
    Dim Tmp As String
    Dim Arr, dArr
    Application.ScreenUpdating = False
Sheets("ONVSUIK").Range("A2:U65536").ClearContents
Set Rng = Sheets("ONVSUIK").Range("A2")
FilesToImport = Application.GetOpenFilename("Text Files (*.txt), *.txt", , , , True)
If IsArray(FilesToImport) Then
    Set FSO = CreateObject("Scripting.FileSystemObject")
    For Index = 1 To UBound(FilesToImport)
        n = 0
        Set TextSource = FSO.OpenTextFile(FilesToImport(Index), 1, , -2)
        NumOfLines = Split(TextSource.ReadAll, vbCrLf)
        
        If UBound(NumOfLines) > 0 Then
            ReDim Res(1 To UBound(NumOfLines), 1 To 1)
            For row = 1 To UBound(NumOfLines)
                Text = NumOfLines(row)
                If Text <> "" Then
                    If Text <> String(Len(Text), ",") Then
                        n = n + 1
                        Cols = Split(Text, ",")
                        If UBound(Res, 2) < UBound(Cols) + 1 Then
                            ReDim Preserve Res(1 To UBound(NumOfLines), 1 To UBound(Cols) + 1)
                        End If
                        For col = 1 To UBound(Res, 2)
                            Res(n, col) = Replace(Cols(col - 1), """", "")
                        Next
                    End If
                End If
            Next
        End If
        Rng.Resize(n, UBound(Res, 2)).Value = Res
        Set Rng = Rng.Offset(n)
    Next
End If
Arr = Range(Sheet1.[A2], Sheet1.[U60000].End(3)).Resize(, 21)
    ReDim dArr(1 To UBound(Arr, 1), 1 To UBound(Arr, 2))
    Set Dic = CreateObject("Scripting.Dictionary")
    With Dic
        For i = 1 To UBound(Arr, 1)
             Tmp = Arr(i, 2) & "#" & Arr(i, 3) & "#" & Arr(i, 4) & "#"
            If Not .Exists(Tmp) Then
                k = k + 1
                .Add Tmp, k
                For j = 1 To UBound(Arr, 2)
                    dArr(k, j) = Arr(i, j)
                Next j
            Else
                dArr(.Item(Tmp), 6) = dArr(.Item(Tmp), 6) + Arr(i, 6)
                dArr(.Item(Tmp), 7) = dArr(.Item(Tmp), 7) + Arr(i, 7)
                dArr(.Item(Tmp), 8) = dArr(.Item(Tmp), 8) + Arr(i, 8)
                dArr(.Item(Tmp), 9) = dArr(.Item(Tmp), 9) + Arr(i, 9)
                dArr(.Item(Tmp), 10) = dArr(.Item(Tmp), 10) + Arr(i, 10)
                dArr(.Item(Tmp), 11) = dArr(.Item(Tmp), 11) + Arr(i, 11)
                dArr(.Item(Tmp), 12) = dArr(.Item(Tmp), 12) + Arr(i, 12)
                dArr(.Item(Tmp), 13) = dArr(.Item(Tmp), 13) + Arr(i, 13)
                dArr(.Item(Tmp), 14) = dArr(.Item(Tmp), 14) + Arr(i, 14)
                dArr(.Item(Tmp), 15) = dArr(.Item(Tmp), 15) + Arr(i, 15)
                dArr(.Item(Tmp), 16) = dArr(.Item(Tmp), 16) + Arr(i, 16)
                dArr(.Item(Tmp), 17) = dArr(.Item(Tmp), 17) + Arr(i, 17)
                dArr(.Item(Tmp), 18) = dArr(.Item(Tmp), 18) + Arr(i, 18)
                dArr(.Item(Tmp), 19) = dArr(.Item(Tmp), 19) + Arr(i, 19)
                dArr(.Item(Tmp), 20) = dArr(.Item(Tmp), 20) + Arr(i, 20)
                dArr(.Item(Tmp), 21) = dArr(.Item(Tmp), 21) + Arr(i, 21)
            End If
        Next i
    End With
    Sheet1.Range("A2").Resize(1000, 21).ClearContents
    Sheet1.Range("A2").Resize(k, UBound(Arr, 2)) = dArr
    Application.ScreenUpdating = True
End Sub
 

File đính kèm

Lần chỉnh sửa cuối:
Upvote 0
LamNA đã viết:
Em nhớ có hỏi anh 1 lần về cái này mà áp dụng còn bỡ ngỡ
Bài đã được tự động gộp:


Theo gợi ý của bác @HieuCD , em gom 2 sub thành một cho anh đã lọc trùng và tính tổng, anh kiểm tra xem có sai xót gì không nhé

Mã: 
Sub NhapFile_TXT_LocTrung()
Dim Index As Long, n As Long, col As Long, row As Long, Text As String
Dim Rng As Range, FSO As Object, FilesToImport
Dim TextSource As Object, NumOfLines, Cols, Res()
Dim Dic As Object
    Dim i As Long, j As Long, k As Long
    Dim Tmp As String
    Dim Arr, dArr
    Application.ScreenUpdating = False
Sheets("ONVSUIK").Range("A2:U65536").ClearContents
Set Rng = Sheets("ONVSUIK").Range("A2")
FilesToImport = Application.GetOpenFilename("Text Files (*.txt), *.txt", , , , True)
If IsArray(FilesToImport) Then
    Set FSO = CreateObject("Scripting.FileSystemObject")
    For Index = 1 To UBound(FilesToImport)
        n = 0
        Set TextSource = FSO.OpenTextFile(FilesToImport(Index), 1, , -2)
        NumOfLines = Split(TextSource.ReadAll, vbCrLf)
      
        If UBound(NumOfLines) > 0 Then
            ReDim Res(1 To UBound(NumOfLines), 1 To 1)
            For row = 1 To UBound(NumOfLines)
                Text = NumOfLines(row)
                If Text <> "" Then
                    If Text <> String(Len(Text), ",") Then
                        n = n + 1
                        Cols = Split(Text, ",")
                        If UBound(Res, 2) < UBound(Cols) + 1 Then
                            ReDim Preserve Res(1 To UBound(NumOfLines), 1 To UBound(Cols) + 1)
                        End If
                        For col = 1 To UBound(Res, 2)
                            Res(n, col) = Replace(Cols(col - 1), """", "")
                        Next
                    End If
                End If
            Next
        End If
        Rng.Resize(n, UBound(Res, 2)).Value = Res
        Set Rng = Rng.Offset(n)
    Next
End If
Arr = Range(Sheet1.[A2], Sheet1.[U60000].End(3)).Resize(, 21)
    ReDim dArr(1 To UBound(Arr, 1), 1 To UBound(Arr, 2))
    Set Dic = CreateObject("Scripting.Dictionary")
    With Dic
        For i = 1 To UBound(Arr, 1)
             Tmp = Arr(i, 2) & "#" & Arr(i, 3) & "#" & Arr(i, 4) & "#"
            If Not .Exists(Tmp) Then
                k = k + 1
                .Add Tmp, k
                For j = 1 To UBound(Arr, 2)
                    dArr(k, j) = Arr(i, j)
                Next j
            Else
                dArr(.Item(Tmp), 6) = dArr(.Item(Tmp), 6) + Arr(i, 6)
                dArr(.Item(Tmp), 7) = dArr(.Item(Tmp), 7) + Arr(i, 7)
                dArr(.Item(Tmp), 8) = dArr(.Item(Tmp), 8) + Arr(i, 8)
                dArr(.Item(Tmp), 9) = dArr(.Item(Tmp), 9) + Arr(i, 9)
                dArr(.Item(Tmp), 10) = dArr(.Item(Tmp), 10) + Arr(i, 10)
                dArr(.Item(Tmp), 11) = dArr(.Item(Tmp), 11) + Arr(i, 11)
                dArr(.Item(Tmp), 12) = dArr(.Item(Tmp), 12) + Arr(i, 12)
                dArr(.Item(Tmp), 13) = dArr(.Item(Tmp), 13) + Arr(i, 13)
                dArr(.Item(Tmp), 14) = dArr(.Item(Tmp), 14) + Arr(i, 14)
                dArr(.Item(Tmp), 15) = dArr(.Item(Tmp), 15) + Arr(i, 15)
                dArr(.Item(Tmp), 16) = dArr(.Item(Tmp), 16) + Arr(i, 16)
                dArr(.Item(Tmp), 17) = dArr(.Item(Tmp), 17) + Arr(i, 17)
                dArr(.Item(Tmp), 18) = dArr(.Item(Tmp), 18) + Arr(i, 18)
                dArr(.Item(Tmp), 19) = dArr(.Item(Tmp), 19) + Arr(i, 19)
                dArr(.Item(Tmp), 20) = dArr(.Item(Tmp), 20) + Arr(i, 20)
                dArr(.Item(Tmp), 21) = dArr(.Item(Tmp), 21) + Arr(i, 21)
            End If
        Next i
    End With
    Sheet1.Range("A2").Resize(1000, 21).ClearContents
    Sheet1.Range("A2").Resize(k, UBound(Arr, 2)) = dArr
    Application.ScreenUpdating = True
End Sub
Nhấp chuột vào đây để mở rộng...
Gộp 2 vòng for lại cho gọn
Mã: 
Sub NhapFile_TXT_LocTrung()
  Dim Index As Long, col As Long, row As Long, k As Long, ik As Long
  Dim FSO As Object, FilesToImport
  Dim TextSource As Object, NumOfLines, Cols, Res()
  Dim Dic As Object, Tmp As String, Text As String

Application.ScreenUpdating = False
ReDim Res(1 To 65536, 0 To 20)

FilesToImport = Application.GetOpenFilename("Text Files (*.txt), *.txt", , , , True)
If IsArray(FilesToImport) Then
    Set Dic = CreateObject("Scripting.Dictionary")
    Set FSO = CreateObject("Scripting.FileSystemObject")
    For Index = 1 To UBound(FilesToImport)
        Set TextSource = FSO.OpenTextFile(FilesToImport(Index), 1, , -2)
        NumOfLines = Split(TextSource.ReadAll, vbCrLf)
        If UBound(NumOfLines) > 0 Then
            For row = 1 To UBound(NumOfLines)
                Text = NumOfLines(row)
                If Text <> "" Then
                    If Text <> String(Len(Text), ",") Then
                        Cols = Split(Text, ",")
                        For col = 0 To 20
                            If col >= 5 Then
                              Cols(col) = Val(Cols(col))
                            Else
                              Cols(col) = Application.Trim(Cols(col))
                            End If
                        Next
                        Tmp = Cols(1) & "#" & Cols(2) & "#" & Cols(3)
                        If Not Dic.Exists(Tmp) Then
                            k = k + 1
                            Dic.Add Tmp, k
                            For col = 0 To 20
                              Res(k, col) = Cols(col)
                            Next col
                        Else
                          ik = Dic.Item(Tmp)
                          For col = 5 To 20
                            Res(ik, col) = Res(ik, col) + Cols(col)
                          Next col
                        End If
                    End If
                End If
            Next
        End If
    Next
End If
With Sheets("ONVSUIK")
    row = .Range("A1000000").End(xlUp).row
    If row > 1 Then .Range("A2:U" & row).ClearContents
    If k Then .Range("A2").Resize(k, 21) = Res
End With
Application.ScreenUpdating = True
End Sub
 
Upvote 0
Bác @HieuCD ơi
Bác @LamNA ơi

Đáp án bài #22 vẫn chưa chính xác .
Mình dùm code của bác @HieuCD thì :

Code cộng dòng trùng , có dòng trùng nó cộng lại rồi nhưng lại dư 1 con số 0 phía sau .
VD 10000 thì nó 100000
30000 tthì nó 300000
54930 thì nó 549300
Suiko17-1
11​
1100114​
HAX1 14 GN STOCK
0​
0​
30000​
0​
0​
0​
0​
59430​
39550​
10100​
0​
0​
0​
0​
0​
4000​
Suiko17-5
11​
1100114​
HAX1 14 GN STOCK
0​
100000​
0​
0​
0​
0​
0​
0​
0​
0​
0​
0​
0​
0​
0​
0​
Dùng code : tổng họp ra kết qua dư 1 số 0
11​
1100114​
HAX1 14GNSTOCK
0​
100000​
300000​
0​
0​
0​
0​
594300​
395500​
101000​
0​
0​
0​
0​
0​
40000​

Các dòng không trùng thì bình thường .
02 bác xem lại giúp em

*** File đính kèm : ssố liệu em giới hạn lại để kiểm tra
File SUIKO17-5 : có 1 dòng số liệu
File SUIKO17_1 : có 9 dòng số liệu

Khi tổng họp lại dòng trùng có số liệu dư 1 con số 0 đằng sau .

1 lần nữa xin cám ơn 02 bác
 

File đính kèm

Lần chỉnh sửa cuối:
Upvote 0
happyghost2000 đã viết:
Bác @HieuCD ơi
Bác @LamNA ơi

Đáp án bài #22 vẫn chưa chính xác .
Mình dùm code của bác @HieuCD thì :

Code cộng dòng trùng , có dòng trùng nó cộng lại rồi nhưng lại dư 1 con số 0 phía sau .
VD 10000 thì nó 100000
30000 tthì nó 300000
54930 thì nó 549300
Suiko17-1
11​
1100114​
HAX1 14 GNSTOCK
0​
0​
30000​
0​
0​
0​
0​
59430​
39550​
10100​
0​
0​
0​
0​
0​
4000​
Suiko17-5
11​
1100114​
HAX1 14 GNSTOCK
0​
100000​
0​
0​
0​
0​
0​
0​
0​
0​
0​
0​
0​
0​
0​
0​
Dùng code : tổng họp ra kết qua dư 1 số 0
11​
1100114​
HAX1 14GNSTOCK
0​
100000​
300000​
0​
0​
0​
0​
594300​
395500​
101000​
0​
0​
0​
0​
0​
40000​

Các dòng không trùng thì bình thường .
02 bác xem lại giúp em

*** File đính kèm : ssố liệu em giới hạn lại để kiểm tra
File SUIKO17-5 : có 1 dòng số liệu
File SUIKO17_1 : có 9 dòng số liệu

Khi tổng họp lại dòng trùng có số liệu dư 1 con số 0 đằng sau .

1 lần nữa xin cám ơn 02 bác
Nhấp chuột vào đây để mở rộng...
Không hiểu tại sao hàm Val không có tác dụng cho mảng Cols, thêm 1 mảng trung gian
Mã: 
Sub NhapFile_TXT_LocTrung()
  Dim Index As Long, col As Long, row As Long, k As Long, ik As Long
  Dim FSO As Object, FilesToImport
  Dim TextSource As Object, NumOfLines, Cols, Arr(), Res()
  Dim Dic As Object, Tmp As String, Text As String

Application.ScreenUpdating = False
ReDim Res(1 To 65536, 0 To 20)
ReDim Arr(0 To 20)
FilesToImport = Application.GetOpenFilename("Text Files (*.txt), *.txt", , , , True)
If IsArray(FilesToImport) Then
    Set Dic = CreateObject("Scripting.Dictionary")
    Set FSO = CreateObject("Scripting.FileSystemObject")
    For Index = 1 To UBound(FilesToImport)
        Set TextSource = FSO.OpenTextFile(FilesToImport(Index), 1, , -2)
        NumOfLines = Split(TextSource.ReadAll, vbCrLf)
        If UBound(NumOfLines) > 0 Then
            For row = 1 To UBound(NumOfLines)
                Text = NumOfLines(row)
                If Text <> "" Then
                    If Text <> String(Len(Text), ",") Then
                        Cols = Split(Text, ",")
                        For col = 0 To 20
                            Arr(col) = Application.Trim(Cols(col))
                            If col >= 5 Then Arr(col) = Val(Arr(col))
                        Next
                        Tmp = Arr(1) & "#" & Arr(2) & "#" & Arr(3)
                        If Not Dic.Exists(Tmp) Then
                            k = k + 1
                            Dic.Add Tmp, k
                            For col = 0 To 20
                              Res(k, col) = Arr(col)
                            Next col
                        Else
                          ik = Dic.Item(Tmp)
                          For col = 5 To 20
                            Res(ik, col) = Res(ik, col) + Arr(col)
                          Next col
                        End If
                    End If
                End If
            Next
        End If
    Next
End If
With Sheets("ONVSUIK")
    row = .Range("A1000000").End(xlUp).row
    If row > 1 Then .Range("A2:U" & row).ClearContents
    If k Then .Range("A2").Resize(k, 21) = Res
End With
Application.ScreenUpdating = True
End Sub
 
Upvote 0
HieuCD đã viết:
Không hiểu tại sao hàm Val không có tác dụng cho mảng Cols, thêm 1 mảng trung gian
Nhấp chuột vào đây để mở rộng...

Perfect . :1a:

Thanks Bác @HieuCD nhiều lắm

Em cũng cám ơn bác @LamNA

Nhờ 02 bác em học thêm được rất nhiều , mặc dùm Code của các bác em mới chỉ hiểu được 20% . ( Em sẽ cố gắng nhiều )

Các bác tư vấn dùm em lớp học nào học VBA từ cơ bản đến nâng cao để em theo học. Hiện giờ em học lõm online nên không có nền tản . bị tẩu hỏa luôn .
 
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

Nauduong
Cách chuyển định dạng từ PDF sang Image
Trả lời
7
Đọc
174
LAM2014
LAM2014
Momominh
Sơ đồ hàng hóa trong Container
Trả lời
1
Đọc
26
tranhungdao12a3
T
N
Nhờ các bác chỉnh hộ ạ
Trả lời
0
Đọc
16
nana1207
N
T
File quản lý thiết bị trong trường học!
Trả lời
1
Đọc
42
thuytrangbp28
T
S
  • Question Question
Điều chỉnh kích thước dòng tự động theo trang in
Trả lời
4
Đọc
82
HeSanbi
HeSanbi
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
4
Đọc
203
Duy Tùng 9x
Duy Tùng 9x
H
Xin viết dùng mã vba thay thế cho hàm vlookup
    • Thích
12 13 14
Trả lời
264
Đọc
79K
VetMini
V
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
35
Đọc
724
VetMini
V
minhduongct
  • Question Question
Viết code VBA thay cho dùng hàm vlookup
Trả lời
5
Đọc
1K
Hoàng Tuấn 868
H
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
22
Đọc
18K
yeudoi
yeudoi
T
Định dạng cột dữ liệu trong sql
Trả lời
5
Đọc
122
ptm0412
ptm0412
L
  • Question Question
[Hlep] Xóa ảnh theo tên và kích thước
Trả lời
8
Đọc
185
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
86
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
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
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
210
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
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