Cần xin hàm tự tạo rút gọn cột chứa dữ liệu và khoảng trống trên 70.000 dòng

Liên hệ QC
M

ManhDuc1382

Supreme Сasual Dating - Verified Maidens
Tham gia
5/3/20
Bài viết
46
Được thích
16
Giới tính
Nam
Nghề nghiệp
Health
Chào các bạn. Mình đang có thắc mắc liên quan đến hàm có thể rút gọn được cột chứa dữ liệu và khoảng trống mà có độ dài trên 70 nghìn dòng theo như mô tả trong file đính kèm. Các bạn giúp mình với nhé, hàm có tốc độ xử lý càng nhanh càng tốt. Mình cảm ơn :D
 

File đính kèm

  • Cần xin hàm VBA rút gọn cột chứa dữ liệu và khoảng trống trên 70.000 dòng.xlsx
    10.2 KB · Đọc: 21
Sắp xếp theo thời gian sắp xếp theo bầu chọn
ManhDuc1382 đã viết:
Chào các bạn. Mình đang có thắc mắc liên quan đến hàm có thể rút gọn được cột chứa dữ liệu và khoảng trống mà có độ dài trên 70 nghìn dòng theo như mô tả trong file đính kèm. Các bạn giúp mình với nhé, hàm có tốc độ xử lý càng nhanh càng tốt. Mình cảm ơn :D
Nhấp chuột vào đây để mở rộng...
Thử code sau:
Mã: 
Sub Copy()
    Dim Vung As Integer
    Vung = Range("E" & Rows.Count).End(xlUp).Row
    Range("E5:E" & Vung).SpecialCells(xlCellTypeConstants).Copy Range("G5")
End Sub
 
Upvote 0
be09 đã viết:
Thử code sau:
Mã: 
Sub Copy()
    Dim Vung As Integer
    Vung = Range("E" & Rows.Count).End(xlUp).Row
    Range("E5:E" & Vung).SpecialCells(xlCellTypeConstants).Copy Range("G5")
End Sub
Nhấp chuột vào đây để mở rộng...
- Tên thủ tục trùng với từ khoá, không cho chạy
- Ô chứa dữ liệu là kết quả của công thức không được mang sang
 
Upvote 0
Tham khảo bài viết:
www.giaiphapexcel.com

Cách xóa các dòng trống trong excel.

Hi mọi người, bình thường khi xóa các dòng trống e vẫn thường làm như sau: - Từ dòng có dữ liệu cuối cùng, chọn các dòng trống còn lại bằng tổ hợp :Ctrl + Shift + mũi tên xuống". - Sau đó xóa hết bằng "Ctrl -" - Bấm Lưu, tắt file mở lại là xong, khi kéo chuột nó sẽ kéo xún dòng cuối cùng có dữ...
www.giaiphapexcel.com www.giaiphapexcel.com

Hoặc sử dụng Hàm UDF:
Cách sử dụng:
Gõ vào ô bất kì ngoài vùng dữ liệu:
Duyệt tất cả cột:​
=S_RemoveRowsBlank(A1:Z100000,0)​
Duyệt cột 1 , cột A:​
=S_RemoveRowsBlank(A1:Z100000,1) Hoặc =S_RemoveRowsBlank(A1,"A")​
Duyệt nhiều cột:​
=S_RemoveRowsBlank(A1:Z100000,"A,C:H")​


Copy code dưới vào một Module
---------------------------------
JavaScript: 
Option Explicit

#If VBA7 Then
  Private Declare PtrSafe Function SetTimer Lib "USER32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr, ByVal uElapse As LongPtr, ByVal lpTimerFunc As LongPtr) As Long
  Private Declare PtrSafe Function KillTimer Lib "USER32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr) As Long
#Else
  Private Declare Function SetTimer Lib "user32" (ByVal HWnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
  Private Declare Function KillTimer Lib "user32" (ByVal HWnd As Long, ByVal nIDEvent As Long) As Long
#End If

'///////////////////////////////////////////////////////
#If Win64 Then
  Private gTimerID As LongPtr
#Else
  Private gTimerID As Long
#End If
'///////////////////////////////////////////////////////
Private RemoveRowsBlankArgs(), RemoveRowsBlankIndex As Integer

Function S_RemoveRowsBlank(ByVal WithCell As Excel.Range, _
                  Optional ByVal ColumnsCheckNull As String = "0") As String
  On Error Resume Next
  KillTimer 0&, gTimerID: gTimerID = 0
  '-----------------------------------------------
  S_RemoveRowsBlank = VBA.Replace(VBA.Mid(Application.Caller.Formula, 2), "S_RemoveRowsBlank", "S_RemoveRowsBlank", , , 1)
  '-----------------------------------------------
  Dim UB As Integer, i As Integer, f As Integer, K As Integer, Fit, Arg
  Set WithCell = WithCell.Parent.Range(WithCell.Address)
  '-----------------------------------------------
  UB = UBound(RemoveRowsBlankArgs, 2): K = UB
  If K > 0 Then GoSub CheckIn
  If f = 0 Then K = K + 1:
  ReDim Preserve RemoveRowsBlankArgs(1 To 2, 1 To K)
  Set RemoveRowsBlankArgs(1, K) = WithCell
  RemoveRowsBlankArgs(2, K) = VBA.Replace(ColumnsCheckNull, " ", "")
  gTimerID = SetTimer(0&, 0&, 0, AddressOf S_RemoveRowsBlank_callback)
Exit Function
CheckIn:
  i = VBA.IIf(RemoveRowsBlankIndex > 0 And RemoveRowsBlankIndex <= K, RemoveRowsBlankIndex, 1)
  For f = i To K
    If RemoveRowsBlankArgs(1, f).Worksheet Is WithCell.Worksheet Then
      If RemoveRowsBlankArgs(1, f).Address = WithCell.Address Then Return
    End If
  Next
  f = 0
Return
End Function
'///////////////////////////////////////////////////////
Private Sub S_RemoveRowsBlank_callback()
  On Error Resume Next
  Static EarliestTime As Date, Procedure As String
  Procedure = "'" & ThisWorkbook.Name & "'!S_RemoveRowsBlank_callback"
  Call KillTimer(0&, gTimerID): gTimerID = 0
  Call Application.OnTime(EarliestTime, Procedure, , False)
  '----------------------------------
  Dim UB As Integer
  UB = UBound(RemoveRowsBlankArgs, 2)
  If UB > 0 Then
    RemoveRowsBlankIndex = RemoveRowsBlankIndex + 1
    Call RemoveRowsBlank(RemoveRowsBlankArgs(1, RemoveRowsBlankIndex), RemoveRowsBlankArgs(2, RemoveRowsBlankIndex))
    If RemoveRowsBlankIndex >= UB Then
      Erase RemoveRowsBlankArgs: RemoveRowsBlankIndex = 0
    Else
      EarliestTime = VBA.Now()
      Call Application.OnTime(EarliestTime, Procedure)
    End If
  End If
End Sub

Private Sub RemoveRowsBlank(Optional ByVal Target As Range, Optional ByVal ColumnsCheckNull As String = "1")
  Dim Arr, cdt As String
  Dim r&, c%, cc%, LC&, LR&
  On Error Resume Next
  With Target.Parent
    LR = Target.Rows.Count: LC = Target.Columns.Count
    If LR <= 2 Or LC <= 0 Then Exit Sub
    On Error Resume Next
    Dim CN As Object, Rs As Object
    Set CN = VBA.Interaction.CreateObject("ADODB.Connection")
    CN.Open SyncConnectionXL(Target.Parent.Parent.FullName, , False)
    If ColumnsCheckNull <= "0" Then
      For c = 1 To LC
        cdt = cdt & IIf(cdt = "", "", " OR ") & "(F" & CStr(c) & " IS NOT NULL)"
      Next
    Else
      Dim SP() As String, rr%
      SP = Split(ColumnsCheckNull, ",")
      For c = 0 To UBound(SP)
        If VBA.IsNumeric(SP(c)) Then
          cdt = cdt & IIf(cdt = "", "", " OR ") & "(F" & CStr(SP(c)) & " IS NOT NULL)"
        Else
          For cc = Columns(SP(c)).Column To Columns(SP(c)).Column + Columns(SP(c)).Columns.Count - 1
            If cc - Target.Row + 1 > 0 Then
              cdt = cdt & IIf(cdt = "", "", " OR ") & "(F" & CStr(cc - Target.Row + 1) & " IS NOT NULL)"
            End If
          Next
        End If
      Next
    End If
    Err.Clear
    Set Rs = CN.Execute("SELECT * FROM [" & .Name & "$" & Target.Address(0, 0) & "] WHERE (" & cdt & ")")
    If Err.Number = 0 Then
      If Not Rs.EOF Then
        r = Target.CopyFromRecordset(Rs)
      End If
    End If
    Rs.Close
    If LR - r > 0 And r > 0 Then
      Target(r + 1, 1).Resize(LR - r, LC).ClearContents
    End If
    Set CN = Nothing: Set Rs = Nothing
  End With
Ends:
  On Error GoTo 0
End Sub
Public Function SyncConnectionXL(ByVal DataSource As String, _
                        Optional ByVal Mode As String = "Read", _
                        Optional ByVal Header As Boolean = True, _
                        Optional ByVal FormatFileText As String = "Delimited") As String
  Dim cnt As String, XL As String, HDR As String
  HDR = VBA.IIf(Header, "YES", "NO")
  If Application.Version >= 12 Then
    XL = "12.0": cnt = ("provider=Microsoft.ACE.OLEDB.12.0;Data source='" & DataSource & "';mode=" & Mode & ";")
  Else
    XL = "8.0": cnt = ("Provider=Microsoft.Jet.OLEDB.4.0;Data Source='" & DataSource & "';mode=" & Mode & ";")
  End If
  DataSource = VBA.LCase(DataSource)
  Select Case Right(DataSource, 4)
  Case "xlsx":
    cnt = cnt & "Extended Properties=""Excel " & XL & " Xml;HDR=" & HDR & ";imex=1"";"
  Case ".csv", ".txt":
    cnt = cnt & "Extended Properties=""Text;HDR=" & HDR & ";FMT=" & FormatFileText & ";"";"
  Case "xlsb":
    cnt = cnt & "Extended Properties=""Excel " & XL & ";HDR=" & HDR & ";"";"
  Case "xlsm", "xlam":
    cnt = cnt & "Extended Properties=""Excel " & XL & " Macro;HDR=" & HDR & ";"";"
  Case ".xla", ".xls"
    cnt = cnt & "Extended Properties=""Excel 8.0;HDR=" & HDR & ";"";"
  End Select
  SyncConnectionXL = cnt
End Function
 
Lần chỉnh sửa cuối:
Upvote 0
ptm0412 đã viết:
- Tên thủ tục trùng với từ khoá, không cho chạy
- Ô chứa dữ liệu là kết quả của công thức không được mang sang
Nhấp chuột vào đây để mở rộng...
Cột E dữ liệu là không liền lạc, nhưng chủ Topic đưa dữ liệu nữa chừng (tiêu đề không đầy đủ) vì vậy anh chỉ đưa code khái quát chủ Topic sẽ tự khắc hiểu biết đặt biến là dựa vào cột nào để sửa cho phù hợp.
File bài 1 không có hàm, nếu họ có sử dụng hàm mà code chưa đáp ứng được yêu cầu thì tự khắc họ sẽ la lên.
 
Lần chỉnh sửa cuối:
Upvote 0
be09 đã viết:
Thử code sau:
Mã: 
Sub Copy()
    Dim Vung As Integer
    Vung = Range("E" & Rows.Count).End(xlUp).Row
    Range("E5:E" & Vung).SpecialCells(xlCellTypeConstants).Copy Range("G5")
End Sub
Nhấp chuột vào đây để mở rộng...
mình cảm ơn bạn
Bài đã được tự động gộp:

HeSanbi đã viết:
Tham khảo bài viết:
www.giaiphapexcel.com

Cách xóa các dòng trống trong excel.

Hi mọi người, bình thường khi xóa các dòng trống e vẫn thường làm như sau: - Từ dòng có dữ liệu cuối cùng, chọn các dòng trống còn lại bằng tổ hợp :Ctrl + Shift + mũi tên xuống". - Sau đó xóa hết bằng "Ctrl -" - Bấm Lưu, tắt file mở lại là xong, khi kéo chuột nó sẽ kéo xún dòng cuối cùng có dữ...
www.giaiphapexcel.com www.giaiphapexcel.com

Hoặc sử dụng Hàm UDF:
Cách sử dụng:
Gõ vào ô bất kì ngoài vùng dữ liệu:
Duyệt tất cả cột:​
=S_RemoveRowsBlank(A1,0)​
Duyệt cột 1 , cột A:​
=S_RemoveRowsBlank(A1,1) Hoặc =S_RemoveRowsBlank(A1,"A")​
Duyệt nhiều cột:​
=S_RemoveRowsBlank(A1,"A,C:H")​


Copy code dưới vào một Module
---------------------------------
JavaScript: 
Option Explicit

#If VBA7 Then
  Private Declare PtrSafe Function SetTimer Lib "USER32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr, ByVal uElapse As LongPtr, ByVal lpTimerFunc As LongPtr) As Long
  Private Declare PtrSafe Function KillTimer Lib "USER32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr) As Long
#Else
  Private Declare Function SetTimer Lib "user32" (ByVal HWnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
  Private Declare Function KillTimer Lib "user32" (ByVal HWnd As Long, ByVal nIDEvent As Long) As Long
#End If

'///////////////////////////////////////////////////////
#If Win64 Then
  Private gTimerID As LongPtr
#Else
  Private gTimerID As Long
#End If
'///////////////////////////////////////////////////////
Private RemoveRowsBlankAgrs(), RemoveRowsBlankIndex As Integer

Function S_RemoveRowsBlank(ByVal WithCell As Excel.Range, _
                  Optional ByVal ColumnsCheckNull As String = "0") As String
  On Error Resume Next
  KillTimer 0&, gTimerID: gTimerID = 0
  '-----------------------------------------------
  S_RemoveRowsBlank = VBA.Replace(VBA.Mid(Application.Caller.Formula, 2), "S_RemoveRowsBlank", "S_RemoveRowsBlank", , , 1)
  '-----------------------------------------------
  Dim UB As Integer, i As Integer, f As Integer, K As Integer, Fit, Arg
  Set WithCell = WithCell.Parent.Range(WithCell.Address)
  '-----------------------------------------------
  UB = UBound(RemoveRowsBlankAgrs, 2): K = UB
  If K > 0 Then GoSub CheckIn
  If f = 0 Then K = K + 1:
  ReDim Preserve RemoveRowsBlankAgrs(1 To 2, 1 To K)
  Set RemoveRowsBlankAgrs(1, K) = WithCell
  RemoveRowsBlankAgrs(2, K) = ColumnsCheckNull
  gTimerID = SetTimer(0&, 0&, 0, AddressOf S_RemoveRowsBlank_callback)
Exit Function
CheckIn:
  i = VBA.IIf(RemoveRowsBlankIndex > 0 And RemoveRowsBlankIndex <= K, RemoveRowsBlankIndex, 1)
  For f = i To K
    If RemoveRowsBlankAgrs(2, f).Worksheet Is WithCell.Worksheet Then
      If RemoveRowsBlankAgrs(2, f).Address = WithCell.Address Then Return
    End If
  Next
  f = 0
Return
End Function
'///////////////////////////////////////////////////////
Private Sub S_RemoveRowsBlank_callback()
  On Error Resume Next
  Static EarliestTime As Date, Procedure As String
  Procedure = "'" & ThisWorkbook.Name & "'!S_RemoveRowsBlank_callback"
  Call KillTimer(0&, gTimerID): gTimerID = 0
  Call Application.OnTime(EarliestTime, Procedure, , False)
  '----------------------------------
  Dim UB As Integer
  UB = UBound(RemoveRowsBlankAgrs, 2)
  If UB > 0 Then
    RemoveRowsBlankIndex = RemoveRowsBlankIndex + 1
    Call RemoveRowsBlank(RemoveRowsBlankAgrs(1, RemoveRowsBlankIndex), RemoveRowsBlankAgrs(2, RemoveRowsBlankIndex))
    If RemoveRowsBlankIndex >= UB Then
      Erase RemoveRowsBlankAgrs: RemoveRowsBlankIndex = 0
    Else
      EarliestTime = VBA.Now()
      Call Application.OnTime(EarliestTime, Procedure)
    End If
  End If
End Sub

Private Sub RemoveRowsBlank(Optional ByVal Target As Range, Optional ByVal ColumnsCheckNull As String = "1")
  Dim Arr, cdt As String
  Dim r&, c%, cc%, LC&, LR&, rng As Range
  On Error Resume Next
  With Target.Parent
    LR = .Cells.Find("*", After:=.Cells(1), LookIn:=xlFormulas, LookAt:=xlWhole, SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row - Target.Row + 1
    LC = .Cells.Find("*", After:=.Cells(1), LookIn:=xlFormulas, LookAt:=xlWhole, SearchDirection:=xlPrevious, SearchOrder:=xlByColumns).Column - Target.Column + 1
    Set rng = Target.Resize(LR, LC)
    If LR <= 2 Or LC <= 0 Then Exit Sub
    On Error Resume Next
    Dim CN As Object, Rs As Object
    Set CN = VBA.Interaction.CreateObject("ADODB.Connection")
    CN.Open SyncConnectionXL(Target.Parent.Parent.FullName, , False)
    If ColumnsCheckNull <= "0" Then
      For c = 1 To LC
        cdt = cdt & IIf(cdt = "", "", " OR ") & "(F" & CStr(c) & " IS NOT NULL)"
      Next
    Else
      Dim SP() As String, rr%
      SP = Split(ColumnsCheckNull, ",")
      For c = 0 To UBound(SP)
        If VBA.IsNumeric(SP(c)) Then
          cdt = cdt & IIf(cdt = "", "", " OR ") & "(F" & CStr(SP(c)) & " IS NOT NULL)"
        Else
          For cc = Columns(SP(c)).Column To Columns(SP(c)).Column + Columns(SP(c)).Columns.Count - 1
            If cc - Target.Row + 1 > 0 Then
              cdt = cdt & IIf(cdt = "", "", " OR ") & "(F" & CStr(cc - Target.Row + 1) & " IS NOT NULL)"
            End If
          Next
        End If
      Next
    End If
    Err.Clear
    Set Rs = CN.Execute("SELECT * FROM [" & .Name & "$" & rng.Address(0, 0) & "] WHERE (" & cdt & ")")
    If Err.Number = 0 Then
      If Not Rs.EOF Then
        r = Target.CopyFromRecordset(Rs)
      End If
    End If
    Rs.Close
    If LR - r > 0 And r > 0 Then
      Target(r + 1, 1).Resize(LR - r, LC).ClearContents
    End If
    Set CN = Nothing: Set Rs = Nothing
  End With
Ends:
  On Error GoTo 0
End Sub
Public Function SyncConnectionXL(ByVal DataSource As String, _
                        Optional ByVal Mode As String = "Read", _
                        Optional ByVal Header As Boolean = True, _
                        Optional ByVal FormatFileText As String = "Delimited") As String
  Dim cnt As String, XL As String, HDR As String
  HDR = VBA.IIf(Header, "YES", "NO")
  If Application.Version >= 12 Then
    XL = "12.0": cnt = ("provider=Microsoft.ACE.OLEDB.12.0;Data source='" & DataSource & "';mode=" & Mode & ";")
  Else
    XL = "8.0": cnt = ("Provider=Microsoft.Jet.OLEDB.4.0;Data Source='" & DataSource & "';mode=" & Mode & ";")
  End If
  DataSource = VBA.LCase(DataSource)
  Select Case Right(DataSource, 4)
  Case "xlsx":
    cnt = cnt & "Extended Properties=""Excel " & XL & " Xml;HDR=" & HDR & ";imex=1"";"
  Case ".csv", ".txt":
    cnt = cnt & "Extended Properties=""Text;HDR=" & HDR & ";FMT=" & FormatFileText & ";"";"
  Case "xlsb":
    cnt = cnt & "Extended Properties=""Excel " & XL & ";HDR=" & HDR & ";"";"
  Case "xlsm", "xlam":
    cnt = cnt & "Extended Properties=""Excel " & XL & " Macro;HDR=" & HDR & ";"";"
  Case ".xla", ".xls"
    cnt = cnt & "Extended Properties=""Excel 8.0;HDR=" & HDR & ";"";"
  End Select
  SyncConnectionXL = cnt
End Function
Nhấp chuột vào đây để mở rộng...
bạn ơi bạn có thể viết giúp mình công thức của hàm SRemoveRowBlank này cho ví dụ trong file đính kèm của mình không --=0 tại là mình thử dùng nhưng chắc do chưa biết dùng nên nó vẫn trắng tinh --=0
 
Lần chỉnh sửa cuối:
Upvote 0
ManhDuc1382 đã viết:
mình cảm ơn bạn
Bài đã được tự động gộp:


bạn ơi bạn có thể viết giúp mình công thức của hàm SRemoveRowBlank này cho ví dụ trong file đính kèm của mình không --=0 tại là mình thử dùng nhưng chắc do chưa biết dùng nên nó vẫn trắng tinh --=0
Nhấp chuột vào đây để mở rộng...
Bạn copy code một lần nữa và đọc lại hướng dẫn. Code lúc trước chỉ phù hợp với Sheet chỉ chứa dữ liệu.

Code lần này sẽ phù hợp với Sheet vừa chứa dữ liệu vừa chứa dữ liệu đã xử lý.
 
Upvote 0
be09 đã viết:
Cột E dữ liệu là không liền lạc, nhưng chủ Topic đưa dữ liệu nữa chừng (tiêu đề không đầy đủ) vì vậy anh chỉ đưa code khái quát chủ Topic sẽ tự khắc hiểu biết đặt biến là dựa vào cột nào để sửa cho phù hợp.
File bài 1 không có hàm, nếu họ có sử dụng hàm mà code chưa đáp ứng được yêu cầu thì tự khắc họ sẽ la lên.
Nhấp chuột vào đây để mở rộng...
Ý tôi nói là tên thủ tục là "Copy" và không chạy được. Còn mục số 2 thì chỉ là dự báo anh sẽ mất công thêm 1 lần nữa
 
Upvote 0
HeSanbi đã viết:
Bạn copy code một lần nữa và đọc lại hướng dẫn. Code lúc trước chỉ phù hợp với Sheet chỉ chứa dữ liệu.

Code lần này sẽ phù hợp với Sheet vừa chứa dữ liệu vừa chứa dữ liệu đã xử lý.
Nhấp chuột vào đây để mở rộng...
ok bạn nhé, để mình thử lại xem, ca này có vẻ khó :''" --=0 --=0
 
Upvote 0
HeSanbi đã viết:
Bạn copy code một lần nữa và đọc lại hướng dẫn. Code lúc trước chỉ phù hợp với Sheet chỉ chứa dữ liệu.

Code lần này sẽ phù hợp với Sheet vừa chứa dữ liệu vừa chứa dữ liệu đã xử lý.
Nhấp chuột vào đây để mở rộng...
bạn ơi bạn xem giúp mình với nhé, mình chưa hiểu được cách dùng hàm này của bạn :wallbash:
 

File đính kèm

  • Chưa dùng được hàm HeSanbi.xlsm
    24.7 KB · Đọc: 4
Upvote 0
Vấn đề của chủ bài đăng là rút gọn bằng UDF, vậy sao không xài Sub mà phải là UDF?
Nếu xài Sub thì chỉ cần xóa các dòng trống trong vùng/cột có được không?
 
Upvote 0
SA_DQ đã viết:
Vấn đề của chủ bài đăng là rút gọn bằng UDF, vậy sao không xài Sub mà phải là UDF?
Nếu xài Sub thì chỉ cần xóa các dòng trống trong vùng/cột có được không?
Nhấp chuột vào đây để mở rộng...
không được bạn ạ, vì mình muốn tạo bảng tổng hợp tự động ý --=0
 
Upvote 0
Bạn giỏi thật --=0 , mình sẽ nghiên cứu dần :")) hẳn nào mà mình viết hàm xong thì nó có mỗi cái đoạn =S_Remove đấy
 
Upvote 0
@ManhDuc1382
Hàm có một chút lỗi bạn copy code dưới thay thế để sửa lỗi.
Không nên viết bất kì hàm nào vào sheet chứa dữ liệu khi có sử dụng ADODB

JavaScript: 
Option Explicit

#If VBA7 Then
  Private Declare PtrSafe Function SetTimer Lib "user32" (ByVal HWnd As LongPtr, ByVal nIDEvent As LongPtr, ByVal uElapse As LongPtr, ByVal lpTimerFunc As LongPtr) As Long
  Private Declare PtrSafe Function KillTimer Lib "user32" (ByVal HWnd As LongPtr, ByVal nIDEvent As LongPtr) As Long
#Else
  Private Declare Function SetTimer Lib "user32" (ByVal HWnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
  Private Declare Function KillTimer Lib "user32" (ByVal HWnd As Long, ByVal nIDEvent As Long) As Long
#End If

'///////////////////////////////////////////////////////
#If Win64 Then
  Private gTimerID As LongPtr, gTimerID2 As LongPtr
#Else
  Private gTimerID As Long, gTimerID2 As Long
#End If
'///////////////////////////////////////////////////////
Private RemoveRowsBlankArgs(), RemoveRowsBlankIndex As Integer
Sub Button1_Click()
  Static i As Integer
  i = i + 1
 
  [A1:B20] = [D1:E20].Value
  Select Case i
  Case 1: [G2].Formula = "=S_RemoveRowsBlank(A1:B20,0)"
  Case 2: [G2].Formula = "=S_RemoveRowsBlank(A1:B20,1)"
  Case Else: [G2].Formula = "=S_RemoveRowsBlank(A1:B20,2)": i = 0
  End Select
End Sub
Sub Button2_Click()
  [A1:B20].ClearContents
End Sub
Function S_RemoveRowsBlank(ByVal WithCell As Excel.Range, _
                  Optional ByVal ColumnsCheckNull As String = "0") As String
  On Error Resume Next
  KillTimer 0&, gTimerID: gTimerID = 0
  '-----------------------------------------------
  S_RemoveRowsBlank = VBA.Replace(VBA.Mid(Application.Caller.Formula, 2), "S_RemoveRowsBlank", "S_RemoveRowsBlank", , , 1)
  '-----------------------------------------------
  Dim UB As Integer, i As Integer, f As Integer, K As Integer, Fit, Arg
  Set WithCell = WithCell.Parent.Range(WithCell.Address)
  '-----------------------------------------------
  UB = UBound(RemoveRowsBlankArgs, 2): K = UB
  If K > 0 Then
    i = VBA.IIf(RemoveRowsBlankIndex > 0 And RemoveRowsBlankIndex <= K, RemoveRowsBlankIndex, 1)
    For f = i To K
      If RemoveRowsBlankArgs(1, f).Worksheet Is WithCell.Worksheet Then
        If Not Application.Intersect(RemoveRowsBlankArgs(1, f), WithCell) Is Nothing Then
          Set RemoveRowsBlankArgs(1, f) = WithCell: GoTo Work: Exit For
        End If
      End If
    Next
    f = 0
  End If
  If f = 0 Then K = K + 1:
  ReDim Preserve RemoveRowsBlankArgs(1 To 2, 1 To K)
  Set RemoveRowsBlankArgs(1, K) = WithCell
Work:
  RemoveRowsBlankArgs(2, K) = VBA.Replace(ColumnsCheckNull, " ", "")
  gTimerID = SetTimer(0&, 0&, 1, AddressOf S_RemoveRowsBlank_callback)
End Function
'///////////////////////////////////////////////////////
Private Sub S_RemoveRowsBlank_callback()
  On Error Resume Next
  Static EarliestTime As Date, Procedure As String
  Call KillTimer(0&, gTimerID): gTimerID = 0
  Call KillTimer(0&, gTimerID2): gTimerID2 = 0
  '----------------------------------
  Dim UB As Integer
  UB = UBound(RemoveRowsBlankArgs, 2)
  If UB > 0 Then
    RemoveRowsBlankIndex = RemoveRowsBlankIndex + 1
    Call RemoveRowsBlank(RemoveRowsBlankArgs(1, RemoveRowsBlankIndex), RemoveRowsBlankArgs(2, RemoveRowsBlankIndex))
    If RemoveRowsBlankIndex >= UB Then
      Erase RemoveRowsBlankArgs: RemoveRowsBlankIndex = 0
    Else
      EarliestTime = VBA.Now()
      gTimerID = SetTimer(0&, 0&, 1, AddressOf S_RemoveRowsBlank_callback2)
    End If
  End If
End Sub
Private Sub S_RemoveRowsBlank_callback2()
  S_RemoveRowsBlank_callback
End Sub
Private Sub RemoveRowsBlank(Optional ByVal Target As Range, Optional ByVal ColumnsCheckNull As String = "1")
  Dim Arr, cdt As String
  Dim r&, c%, cc%, LC&, LR&
  On Error Resume Next

  LR = Target.Rows.Count
  LC = Target.Columns.Count
  On Error Resume Next
  Dim CN As Object, Rs As Object
  Set CN = VBA.Interaction.CreateObject("ADODB.Connection")
  CN.Open SyncConnectionXL(Target.Parent.Parent.FullName, , False)
  If ColumnsCheckNull <= "0" Then
    For c = 1 To LC
      cdt = cdt & IIf(cdt = "", "", " OR ") & "F" & CStr(c) & " IS NOT NULL"
    Next
  Else
    Dim SP() As String, rr%
    SP = Split(ColumnsCheckNull, ",")
    For c = 0 To UBound(SP)
      If VBA.IsNumeric(SP(c)) Then
        cdt = cdt & IIf(cdt = "", "", " OR ") & "F" & CStr(SP(c)) & " IS NOT NULL"
      Else
        For cc = Columns(SP(c)).Column To Columns(SP(c)).Column + Columns(SP(c)).Columns.Count - 1
          If cc - Target.Row + 1 > 0 Then
            cdt = cdt & IIf(cdt = "", "", " OR ") & "(F" & CStr(cc - Target.Row + 1) & " IS NOT NULL)"
          End If
        Next
      End If
    Next
  End If
  Err.Clear
  Set Rs = CN.Execute("SELECT * FROM [" & Target.Parent.Name & "$" & Target.Address(0, 0) & "] WHERE " & cdt & "")
  If Err.Number = 0 Then
    If Not Rs.EOF Then
      r = Target(1, 1).CopyFromRecordset(Rs, , Target.Columns.Count)
    End If
  End If
  Rs.Close
  If LR - r > 0 And r > 0 Then
    Target(r + 1, 1).Resize(LR - r, LC).ClearContents
  End If
  Set CN = Nothing: Set Rs = Nothing
Ends:
  On Error GoTo 0
End Sub
Public Function SyncConnectionXL(ByVal DataSource As String, _
                        Optional ByVal Mode As String = "Read", _
                        Optional ByVal Header As Boolean = True, _
                        Optional ByVal FormatFileText As String = "Delimited") As String
  Dim cnt As String, XL As String, HDR As String
  HDR = VBA.IIf(Header, "YES", "NO")
  If Application.Version >= 12 Then
    XL = "12.0": cnt = ("provider=Microsoft.ACE.OLEDB.12.0;Data source='" & DataSource & "';mode=" & Mode & ";")
  Else
    XL = "8.0": cnt = ("Provider=Microsoft.Jet.OLEDB.4.0;Data Source='" & DataSource & "';mode=" & Mode & ";")
  End If
  DataSource = VBA.LCase(DataSource)
  Select Case Right(DataSource, 4)
  Case "xlsx":
    cnt = cnt & "Extended Properties=""Excel " & XL & " Xml;HDR=" & HDR & ";imex=1"";"
  Case ".csv", ".txt":
    cnt = cnt & "Extended Properties=""Text;HDR=" & HDR & ";FMT=" & FormatFileText & ";"";"
  Case "xlsb":
    cnt = cnt & "Extended Properties=""Excel " & XL & ";HDR=" & HDR & ";"";"
  Case "xlsm", "xlam":
    cnt = cnt & "Extended Properties=""Excel " & XL & " Macro;HDR=" & HDR & ";"";"
  Case ".xla", ".xls"
    cnt = cnt & "Extended Properties=""Excel 8.0;HDR=" & HDR & ";"";"
  End Select
  SyncConnectionXL = cnt
End Function
 
Lần chỉnh sửa cuối:
Upvote 0
HeSanbi đã viết:
@ManhDuc1382
Hàm có một chút lỗi bạn copy code dưới thay thế thủ tục RemoveRowsBlank trong File để sửa lỗi.

JavaScript: 
Private Sub RemoveRowsBlank(Optional ByVal Target As Range, Optional ByVal ColumnsCheckNull As String = "1")
  Dim Arr, cdt As String
  Dim r&, c%, cc%, LC&, LR&
  On Error Resume Next

  LR = Target.Rows.Count
  LC = Target.Columns.Count
  On Error Resume Next
  Dim CN As Object, Rs As Object
  Set CN = VBA.Interaction.CreateObject("ADODB.Connection")
  CN.Open SyncConnectionXL(Target.Parent.Parent.FullName, , False)
  If ColumnsCheckNull <= "0" Then
    For c = 1 To LC
      cdt = cdt & IIf(cdt = "", "", " OR ") & "F" & CStr(c) & " IS NOT NULL"
    Next
  Else
    Dim SP() As String, rr%
    SP = Split(ColumnsCheckNull, ",")
    For c = 0 To UBound(SP)
      If VBA.IsNumeric(SP(c)) Then
        cdt = cdt & IIf(cdt = "", "", " OR ") & "F" & CStr(SP(c)) & " IS NOT NULL"
      Else
        For cc = Columns(SP(c)).Column To Columns(SP(c)).Column + Columns(SP(c)).Columns.Count - 1
          If cc - Target.Row + 1 > 0 Then
            cdt = cdt & IIf(cdt = "", "", " OR ") & "(F" & CStr(cc - Target.Row + 1) & " IS NOT NULL)"
          End If
        Next
      End If
    Next
  End If
  Err.Clear
  Set Rs = CN.Execute("SELECT * FROM [" & Target.Parent.Name & "$" & Target.Address(0, 0) & "] WHERE " & cdt & "")
  If Err.Number = 0 Then
    If Not Rs.EOF Then
      r = Target(1, 1).CopyFromRecordset(Rs, , Target.Columns.Count)
    End If
  End If
  Rs.Close
  If LR - r > 0 And r > 0 Then
    Target(r + 1, 1).Resize(LR - r, LC).ClearContents
  End If
  Set CN = Nothing: Set Rs = Nothing
Ends:
  On Error GoTo 0
End Sub
Nhấp chuột vào đây để mở rộng...
hay đó .... mà sao không viết Hàm gán vào cells đầu tiên của vùng dữ liệu mà cứ tách ra vậy
 
Lần chỉnh sửa cuối:
Upvote 0
HeSanbi đã viết:
@ManhDuc1382
Hàm có một chút lỗi bạn copy code dưới thay thế để sửa lỗi.
Không nên viết bất kì hàm nào vào sheet chứa dữ liệu khi có sử dụng ADODB

JavaScript: 
Option Explicit

#If VBA7 Then
  Private Declare PtrSafe Function SetTimer Lib "user32" (ByVal HWnd As LongPtr, ByVal nIDEvent As LongPtr, ByVal uElapse As LongPtr, ByVal lpTimerFunc As LongPtr) As Long
  Private Declare PtrSafe Function KillTimer Lib "user32" (ByVal HWnd As LongPtr, ByVal nIDEvent As LongPtr) As Long
#Else
  Private Declare Function SetTimer Lib "user32" (ByVal HWnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
  Private Declare Function KillTimer Lib "user32" (ByVal HWnd As Long, ByVal nIDEvent As Long) As Long
#End If

'///////////////////////////////////////////////////////
#If Win64 Then
  Private gTimerID As LongPtr, gTimerID2 As LongPtr
#Else
  Private gTimerID As Long, gTimerID2 As Long
#End If
'///////////////////////////////////////////////////////
Private RemoveRowsBlankArgs(), RemoveRowsBlankIndex As Integer
Sub Button1_Click()
  Static i As Integer
  i = i + 1

  [A1:B20] = [D1:E20].Value
  Select Case i
  Case 1: [G2].Formula = "=S_RemoveRowsBlank(A1:B20,0)"
  Case 2: [G2].Formula = "=S_RemoveRowsBlank(A1:B20,1)"
  Case Else: [G2].Formula = "=S_RemoveRowsBlank(A1:B20,2)": i = 0
  End Select
End Sub
Sub Button2_Click()
  [A1:B20].ClearContents
End Sub
Function S_RemoveRowsBlank(ByVal WithCell As Excel.Range, _
                  Optional ByVal ColumnsCheckNull As String = "0") As String
  On Error Resume Next
  KillTimer 0&, gTimerID: gTimerID = 0
  '-----------------------------------------------
  S_RemoveRowsBlank = VBA.Replace(VBA.Mid(Application.Caller.Formula, 2), "S_RemoveRowsBlank", "S_RemoveRowsBlank", , , 1)
  '-----------------------------------------------
  Dim UB As Integer, i As Integer, f As Integer, K As Integer, Fit, Arg
  Set WithCell = WithCell.Parent.Range(WithCell.Address)
  '-----------------------------------------------
  UB = UBound(RemoveRowsBlankArgs, 2): K = UB
  If K > 0 Then
    i = VBA.IIf(RemoveRowsBlankIndex > 0 And RemoveRowsBlankIndex <= K, RemoveRowsBlankIndex, 1)
    For f = i To K
      If RemoveRowsBlankArgs(1, f).Worksheet Is WithCell.Worksheet Then
        If Not Application.Intersect(RemoveRowsBlankArgs(1, f), WithCell) Is Nothing Then
          Set RemoveRowsBlankArgs(1, f) = WithCell: GoTo Work: Exit For
        End If
      End If
    Next
    f = 0
  End If
  If f = 0 Then K = K + 1:
  ReDim Preserve RemoveRowsBlankArgs(1 To 2, 1 To K)
  Set RemoveRowsBlankArgs(1, K) = WithCell
Work:
  RemoveRowsBlankArgs(2, K) = VBA.Replace(ColumnsCheckNull, " ", "")
  gTimerID = SetTimer(0&, 0&, 1, AddressOf S_RemoveRowsBlank_callback)
End Function
'///////////////////////////////////////////////////////
Private Sub S_RemoveRowsBlank_callback()
  On Error Resume Next
  Static EarliestTime As Date, Procedure As String
  Call KillTimer(0&, gTimerID): gTimerID = 0
  Call KillTimer(0&, gTimerID2): gTimerID2 = 0
  '----------------------------------
  Dim UB As Integer
  UB = UBound(RemoveRowsBlankArgs, 2)
  If UB > 0 Then
    RemoveRowsBlankIndex = RemoveRowsBlankIndex + 1
    Call RemoveRowsBlank(RemoveRowsBlankArgs(1, RemoveRowsBlankIndex), RemoveRowsBlankArgs(2, RemoveRowsBlankIndex))
    If RemoveRowsBlankIndex >= UB Then
      Erase RemoveRowsBlankArgs: RemoveRowsBlankIndex = 0
    Else
      EarliestTime = VBA.Now()
      gTimerID = SetTimer(0&, 0&, 1, AddressOf S_RemoveRowsBlank_callback2)
    End If
  End If
End Sub
Private Sub S_RemoveRowsBlank_callback2()
  S_RemoveRowsBlank_callback
End Sub
Private Sub RemoveRowsBlank(Optional ByVal Target As Range, Optional ByVal ColumnsCheckNull As String = "1")
  Dim Arr, cdt As String
  Dim r&, c%, cc%, LC&, LR&
  On Error Resume Next

  LR = Target.Rows.Count
  LC = Target.Columns.Count
  On Error Resume Next
  Dim CN As Object, Rs As Object
  Set CN = VBA.Interaction.CreateObject("ADODB.Connection")
  CN.Open SyncConnectionXL(Target.Parent.Parent.FullName, , False)
  If ColumnsCheckNull <= "0" Then
    For c = 1 To LC
      cdt = cdt & IIf(cdt = "", "", " OR ") & "F" & CStr(c) & " IS NOT NULL"
    Next
  Else
    Dim SP() As String, rr%
    SP = Split(ColumnsCheckNull, ",")
    For c = 0 To UBound(SP)
      If VBA.IsNumeric(SP(c)) Then
        cdt = cdt & IIf(cdt = "", "", " OR ") & "F" & CStr(SP(c)) & " IS NOT NULL"
      Else
        For cc = Columns(SP(c)).Column To Columns(SP(c)).Column + Columns(SP(c)).Columns.Count - 1
          If cc - Target.Row + 1 > 0 Then
            cdt = cdt & IIf(cdt = "", "", " OR ") & "(F" & CStr(cc - Target.Row + 1) & " IS NOT NULL)"
          End If
        Next
      End If
    Next
  End If
  Err.Clear
  Set Rs = CN.Execute("SELECT * FROM [" & Target.Parent.Name & "$" & Target.Address(0, 0) & "] WHERE " & cdt & "")
  If Err.Number = 0 Then
    If Not Rs.EOF Then
      r = Target(1, 1).CopyFromRecordset(Rs, , Target.Columns.Count)
    End If
  End If
  Rs.Close
  If LR - r > 0 And r > 0 Then
    Target(r + 1, 1).Resize(LR - r, LC).ClearContents
  End If
  Set CN = Nothing: Set Rs = Nothing
Ends:
  On Error GoTo 0
End Sub
Public Function SyncConnectionXL(ByVal DataSource As String, _
                        Optional ByVal Mode As String = "Read", _
                        Optional ByVal Header As Boolean = True, _
                        Optional ByVal FormatFileText As String = "Delimited") As String
  Dim cnt As String, XL As String, HDR As String
  HDR = VBA.IIf(Header, "YES", "NO")
  If Application.Version >= 12 Then
    XL = "12.0": cnt = ("provider=Microsoft.ACE.OLEDB.12.0;Data source='" & DataSource & "';mode=" & Mode & ";")
  Else
    XL = "8.0": cnt = ("Provider=Microsoft.Jet.OLEDB.4.0;Data Source='" & DataSource & "';mode=" & Mode & ";")
  End If
  DataSource = VBA.LCase(DataSource)
  Select Case Right(DataSource, 4)
  Case "xlsx":
    cnt = cnt & "Extended Properties=""Excel " & XL & " Xml;HDR=" & HDR & ";imex=1"";"
  Case ".csv", ".txt":
    cnt = cnt & "Extended Properties=""Text;HDR=" & HDR & ";FMT=" & FormatFileText & ";"";"
  Case "xlsb":
    cnt = cnt & "Extended Properties=""Excel " & XL & ";HDR=" & HDR & ";"";"
  Case "xlsm", "xlam":
    cnt = cnt & "Extended Properties=""Excel " & XL & " Macro;HDR=" & HDR & ";"";"
  Case ".xla", ".xls"
    cnt = cnt & "Extended Properties=""Excel 8.0;HDR=" & HDR & ";"";"
  End Select
  SyncConnectionXL = cnt
End Function
Nhấp chuột vào đây để mở rộng...
mình cảm ơn bạn nhiều nhé, lại có cái để nghiên cứu rồi --=0 --=0 --=0
 
Upvote 0
HeSanbi đã viết:
@ManhDuc1382
Hàm có một chút lỗi bạn copy code dưới thay thế để sửa lỗi.
Không nên viết bất kì hàm nào vào sheet chứa dữ liệu khi có sử dụng ADODB
Nhấp chuột vào đây để mở rộng...
Anh có thể viết cho trường hợp kết quả được trả về ở mảng khác không nằm trong dữ liệu không ạ?
 

File đính kèm

  • HeSanbi UDF.xlsm
    32.2 KB · Đọc: 1
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

Tuấn Bụng Bự
  • Question
Tìm Bộ 8 số xuất hiện nhiều nhất trong random( 1 - 80)
Trả lời
10
Đọc
221
Tuấn Bụng Bự
Tuấn Bụng Bự
ongke0711
  • Question
Tải hóa đơn điện tử (https://hoadondientu.gdt.gov.vn/) Excel Vba
    • Thích
    • Yêu thích
11 12 13
Trả lời
245
Đọc
13K
Hoàng Trọng Hữu
Hoàng Trọng Hữu
H
Hàm đếm số ngày thứ bảy và chủ nhật trong một khoảng thời gian
Trả lời
17
Đọc
19K
Nhattanktnn
Nhattanktnn
D
  • Question
Xin cách sắp xếp dữ liệu theo thứ tự không làm hỏng link
Trả lời
7
Đọc
271
cantl
C
N
Giúp sửa mã code
Trả lời
16
Đọc
241
ptm0412
ptm0412
dung09031989
Xin giúp công thức tô màu các ô phía sau khi kế hoạch đặt hàng thiếu so với tồn kho.?
Trả lời
0
Đọc
28
dung09031989
dung09031989
V
[Nhờ giúp đỡ] Cách tìm thời gian bị trùng trong excel ở nhiều thời gian khác nhau
Trả lời
1
Đọc
36
tranvansau278
T
C
Công thức tự nhập liệu số lượng nhập khi bị âm
Trả lời
0
Đọc
33
cherry0187
C
N
Vẽ biểu đồ kết hợp nhiều yếu tố trong excel
Trả lời
1
Đọc
30
hoangminhtien
hoangminhtien
GPE-Trợ Lý
KHÓA HỌC BỨT PHÁ KỸ NĂNG EXCEL
    • Thích
Trả lời
0
Đọc
132
GPE-Trợ Lý
GPE-Trợ Lý
P
Tổng hợp dữ liệu từ các sheet theo chọn lọc
Trả lời
2
Đọc
71
phutdm
P
dunghtgiga
  • Đã khóa
Tính bốn tuần cho một tháng
Trả lời
9
Đọc
261
ptm0412
ptm0412
zarra
Cần giúp tạo form in mã vạch cho vật tư theo SL cụ thể.
Trả lời
3
Đọc
100
HUONGHCKT
H
Mr Đạo
in giấy ra bị lệch xuống dưới
    • Thích
2
Trả lời
29
Đọc
26K
Hoàng Tuấn 868
H
H
Không xem được ảnh trên Excel
Trả lời
3
Đọc
1K
huyentran9292
H
T
Xin form quản lý dữ liệu học viên của Trung tâm Đào tạo
Trả lời
2
Đọc
214
hakiru188
H
C
Code Lọc Dữ Liệu
Trả lời
10
Đọc
172
Cúc Hr
C
Y
Cách ẩn công thức 1 ô trong sheet
Trả lời
8
Đọc
116
hoangminhtien
hoangminhtien
vuha
  • Question
Lỗi chọn dòng thứ 6 trong sheet được chọn: rows("6:6").select
Trả lời
12
Đọc
157
ptm0412
ptm0412
Nguyencaocuong86
Tô màu dữ liệu trùng lặp trong excel.
Trả lời
10
Đọc
141
Nguyencaocuong86
Nguyencaocuong86
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

Back
Top Bottom