Xử lý khoảng trắng khi lọc qua nhiều sheet về sheet tổng hợp (1 người xem)

[minhcnt491]

Mình có 1 file tổng hợp xà lan ở các bãi, mỗi bãi nhập trên 1 sheet, ở đó có 1 sheet tổng hợp mình đã làm nút cập nhật theo hướng dẫn của anh Hai lúa (sr vì mình nhớ lộn sang a Bate )để khi nhấn nó sẽ tự cập nhật dữ liệu ở các sheet kia về sheet tổng hợp, nhưng khi mình thêm 1 sheet mới thì khi cập nhật nó lại ra 1 khoảng trắng ở giũa.. mong mọi người chỉ giáo :U

 

[thanhsangnguyen1982]

Trong sheet Chipexco bạn xoá từ dòng 24 đến dòng 89 nhấn lại nút cập nhật sẽ ok thôi.

 

[Hai Lúa Miền Tây]

Mình có 1 file tổng hợp xà lan ở các bãi, mỗi bãi nhập trên 1 sheet, ở đó có 1 sheet tổng hợp mình đã làm nút cập nhật theo hướng dẫn của anh Bate để khi nhấn nó sẽ tự cập nhật dữ liệu ở các sheet kia về sheet tổng hợp, nhưng khi mình thêm 1 sheet mới thì khi cập nhật nó lại ra 1 khoảng trắng ở giũa.. mong mọi người chỉ giáo :U

Bạn chỉnh lại code như sau:
[GPECODE=sql]Sub GopSheet_HLMT()
Dim cn As Object, rst As Object, cat As Object, tbl As Object, str$, arr As Variant, i As Integer
Set cn = CreateObject("ADODB.Connection")
Set cat = CreateObject("ADOX.Catalog")
Set tbl = CreateObject("ADOX.Table")
Set rst = CreateObject("ADODB.Recordset")
With cn
.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & ThisWorkbook.FullName & _
";Extended Properties=""Excel 8.0;HDR=Yes;"";"
.Open
End With
cat.ActiveConnection = cn
For Each tbl In cat.Tables
If Right(Replace(tbl.Name, "'", ""), 1) = "$" Then str = str & Replace(Replace(tbl.Name, "$", ""), "'", "") & ";"
Next
arr = Split(str, ";")
For i = 0 To UBound(arr) - 1
Dim str1, str2 As String
If arr(i) <> "TONG" Then
str1 = str1 & " union all SELECT * from [" & arr(i) & "$B12:M65000] where [GRMT] is not null"
str2 = Right(str1, Len(str1) - 10)
End If
Next
With rst
.ActiveConnection = cn
.Open str2
End With
With Sheets("TONG")
.[B12:M65000].ClearContents
.[B12].CopyFromRecordset rst
End With
rst.Close: Set rst = Nothing
cn.Close: Set cn = Nothing
Set cat = Nothing: Set tbl = Nothing: Erase arr

End Sub

[/GPECODE]

P/S: ANh Ba Tê nay sử dụng ADO luôn ta....

 

[hungpecc1]

Mình có 1 file tổng hợp xà lan ở các bãi, mỗi bãi nhập trên 1 sheet, ở đó có 1 sheet tổng hợp mình đã làm nút cập nhật theo hướng dẫn của anh Bate để khi nhấn nó sẽ tự cập nhật dữ liệu ở các sheet kia về sheet tổng hợp, nhưng khi mình thêm 1 sheet mới thì khi cập nhật nó lại ra 1 khoảng trắng ở giũa.. mong mọi người chỉ giáo :U

Bạn thử gửi file bạn đã thêm sheets mới mĩnh xem nào !

 

[hungpecc1]

Bạn chỉnh lại code như sau:
[GPECODE=sql]Sub GopSheet_HLMT()

[/GPECODE]

P/S: ANh Ba Tê nay sử dụng ADO luôn ta....

Em đoán anh Bate định "mượn đao giết người " --> vì code vấn để tên là GopSheet_HLMT()

 

[minhcnt491]

tk mọi người đã góp ý , mình đang chỉnh sửa, nhưng sr a Bate với a Hai Lúa vì mình nhớ lộn 2 a Với nhau . tiện thể cho mình hỏi là trong sheet tổng hợp mình thêm 1 trường tìm kiếm để khi seach dữ liệu về 1 tên tầu nào đó thì sẽ hiện các bản ghi của tầu đó.

mình đã sửa code và thêm sheet nhưng chạy lỗi quá. mình up file mới lên nhờ mọi người chỉnh sửa giúp với nhé
http://mediafire.com/download/4wde4ab6q9zohyf/Tong_hop_tau_dam1.xls

 

[Quang_Hải]

mình đã sửa code và thêm sheet nhưng chạy lỗi quá. mình up file mới lên nhờ mọi người chỉnh sửa giúp với nhé
http://mediafire.com/download/4wde4ab6q9zohyf/Tong_hop_tau_dam1.xls

Thử với code này coi sao

Sub QH_Tonghop()
Dim i As Long, j As Long, k As Long
Dim Result(1 To 10000, 1 To 11), sh As Worksheet, tam()
For Each sh In Worksheets
   If sh.Name <> "TONG" Then
      tam = sh.Range(sh.[B13], sh.[B65536].End(3)).Resize(, 10).Value
      For i = 1 To UBound(tam)
         k = k + 1
         Result(k, 1) = k
         For j = 1 To 10
            Result(k, j + 1) = tam(i, j)
         Next
      Next
   End If
Next
Sheets("TONG").[A12].Resize(k, 11) = Result
End Sub

 

[Hai Lúa Miền Tây]

tk mọi người đã góp ý , mình đang chỉnh sửa, nhưng sr a Bate với a Hai Lúa vì mình nhớ lộn 2 a Với nhau . tiện thể cho mình hỏi là trong sheet tổng hợp mình thêm 1 trường tìm kiếm để khi seach dữ liệu về 1 tên tầu nào đó thì sẽ hiện các bản ghi của tầu đó.

mình đã sửa code và thêm sheet nhưng chạy lỗi quá. mình up file mới lên nhờ mọi người chỉnh sửa giúp với nhé
http://mediafire.com/download/4wde4ab6q9zohyf/Tong_hop_tau_dam1.xls

Chổ màu đỏ mình chưa hiểu ý bạn.

 

[minhcnt491]

Chổ màu đỏ mình chưa hiểu ý bạn.

Đã sửa đc lỗi hàng trắng, nhưng cột PTVT ở sheet Chipexco ko cập nhật vào sheet Tổng hợp. Dòng màu đỏ ý mình là mình dùng 1 cell để nhập tên ptvt ở sheet tổng hợp dùng để tìm kiếm các bản ghi có tên pt trùng với tên pt mà mình nhập ở ô cell đó. nhờ bạn chỉ giáo, tk bạn

 

[Hai Lúa Miền Tây]

Đã sửa đc lỗi hàng trắng, nhưng cột PTVT ở sheet Chipexco ko cập nhật vào sheet Tổng hợp. Dòng màu đỏ ý mình là mình dùng 1 cell để nhập tên ptvt ở sheet tổng hợp dùng để tìm kiếm các bản ghi có tên pt trùng với tên pt mà mình nhập ở ô cell đó. nhờ bạn chỉ giáo, tk bạn

Chỉnh lại 1 chút chổ tô màu đỏ

Sub GopSheet_HLMT()
     Dim cn As Object, rst As Object, cat As Object, tbl As Object, str$, arr As Variant, i As Integer
       Set cn = CreateObject("ADODB.Connection")
       Set cat = CreateObject("ADOX.Catalog")
       Set tbl = CreateObject("ADOX.Table")
       Set rst = CreateObject("ADODB.Recordset")
            With cn
                 .ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
                                     "Data Source=" & ThisWorkbook.FullName & _
                                     ";Extended Properties=""Excel 8.0;HDR=Yes;[COLOR=#ff0000]IMEX=1[/COLOR]"";"
                 .Open
            End With
            cat.ActiveConnection = cn
            For Each tbl In cat.Tables
                If Right(Replace(tbl.Name, "'", ""), 1) = "$" Then str = str & Replace(Replace(tbl.Name, "$", ""), "'", "") & ";"
            Next
            arr = Split(str, ";")
            For i = 0 To UBound(arr) - 1
                Dim str1, str2 As String
                    If arr(i) <> "TONG" Then
                        str1 = str1 & " union all SELECT * from [" & arr(i) & "$B12:k65000] where [GRMT] is not null"
                        str2 = Right(str1, Len(str1) - 10)
                    End If
            Next
           With rst
                .ActiveConnection = cn
                .Open str2
           End With
           With Sheets("TONG")
                .[B12:M65000].ClearContents
                .[B12].CopyFromRecordset rst
           End With
      rst.Close: Set rst = Nothing
      cn.Close: Set cn = Nothing
      Set cat = Nothing: Set tbl = Nothing: Erase arr
      
  End Sub

 

[minhcnt491]

Thử với code này coi sao

Sub QH_Tonghop()
Dim i As Long, j As Long, k As Long
Dim Result(1 To 10000, 1 To 11), sh As Worksheet, tam()
For Each sh In Worksheets
   If sh.Name <> "TONG" Then
      tam = sh.Range(sh.[B13], sh.[B65536].End(3)).Resize(, 10).Value
      For i = 1 To UBound(tam)
         k = k + 1
         Result(k, 1) = k
         For j = 1 To 10
            Result(k, j + 1) = tam(i, j)
         Next
      Next
   End If
Next
Sheets("TONG").[A12].Resize(k, 11) = Result
End Sub

tk bạn. đã sửa code và chạy đc , nhưng cho mình hỏi có cách nào mà các cell ở sheet tổng hợp format theo các cell tương ứng ở các sheet khác .

 

[minhcnt491]

Chỉnh lại 1 chút chổ tô màu đỏ

Sub GopSheet_HLMT()
     Dim cn As Object, rst As Object, cat As Object, tbl As Object, str$, arr As Variant, i As Integer
       Set cn = CreateObject("ADODB.Connection")
       Set cat = CreateObject("ADOX.Catalog")
       Set tbl = CreateObject("ADOX.Table")
       Set rst = CreateObject("ADODB.Recordset")
            With cn
                 .ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
                                     "Data Source=" & ThisWorkbook.FullName & _
                                     ";Extended Properties=""Excel 8.0;HDR=Yes;[COLOR=#ff0000]IMEX=1[/COLOR]"";"
                 .Open
            End With
            cat.ActiveConnection = cn
            For Each tbl In cat.Tables
                If Right(Replace(tbl.Name, "'", ""), 1) = "$" Then str = str & Replace(Replace(tbl.Name, "$", ""), "'", "") & ";"
            Next
            arr = Split(str, ";")
            For i = 0 To UBound(arr) - 1
                Dim str1, str2 As String
                    If arr(i) <> "TONG" Then
                        str1 = str1 & " union all SELECT * from [" & arr(i) & "$B12:k65000] where [GRMT] is not null"
                        str2 = Right(str1, Len(str1) - 10)
                    End If
            Next
           With rst
                .ActiveConnection = cn
                .Open str2
           End With
           With Sheets("TONG")
                .[B12:M65000].ClearContents
                .[B12].CopyFromRecordset rst
           End With
      rst.Close: Set rst = Nothing
      cn.Close: Set cn = Nothing
      Set cat = Nothing: Set tbl = Nothing: Erase arr
      
  End Sub

thank pro nhiều nhé . mình ngâm cứu và phát triển thêm,có j nhờ mọi người giúp nhé

 

[Quang_Hải]

tk bạn. đã sửa code và chạy đc , nhưng cho mình hỏi có cách nào mà các cell ở sheet tổng hợp format theo các cell tương ứng ở các sheet khác .

Thử code này, không thấy sợ như ADO. ADO nhức đầu quá

Sub QH_Tonghop()
Dim sh As Worksheet
   With Sheets("TONG")
      .[A12:K10000].Clear
      For Each sh In Worksheets
         If sh.Name <> "TONG" Then
            sh.Range(sh.[B13], sh.[B65536].End(3)).Resize(, 10).Copy
            .[B65536].End(3)(2).PasteSpecial 1
         End If
      Next
       .Range(.[B12], .[B65536].End(3)).Offset(0, -1) = [row(a:a)]
   End With
End Sub