Private Sub XoaDongTrong()
On Error Resume Next
With Sheet1.UsedRange
.SpecialCells(2).EntireRow.Hidden = True
.SpecialCells(12).EntireRow.Delete
.EntireRow.Hidden = False
End With
End Sub
Private Sub XoaDongTrong()
On Error Resume Next
Sheet1.UsedRange.SpecialCells(4).EntireRow.Delete
End Sub
Private Sub UserForm_Terminate()
Call XoaDongTrong
End Sub
Sub XoaDongTrong()
Dim Arr(), ArrKQ(1 To 60000, 1 To 2)
Dim i As Byte, j As Byte, s As Byte, dk As Boolean, k As Long
k = Sheet1.[A65535].End(xlUp).Row
Arr = Sheet1.[A2].Resize(k - 1, 2).Value
s = 0
For i = 1 To UBound(Arr())
dk = False
For j = 1 To 2
If Arr(i, j) <> "" Then dk = True
Next
If dk = True Then
s = s + 1
For j = 1 To 2
ArrKQ(s, j) = Arr(i, j)
Next
End If
Next
With Sheet1.[A2]
.Resize(k - 1, 2).ClearContents
.Resize(s, 2) = ArrKQ
End With
End Sub
Trời... Nếu có 2 bảng song song thì đầu tiên khi Form load, bạn xác định vùng dữ liệu đi. Ví dụ:Em nghĩ clear và dồn hàng lên là chắc ăn hơn! Bởi đôi khi 2 bảng song song thì không thể dùng UsedRange.SpecialCells(4).EntireRow được!
PHP:Private Sub UserForm_Terminate() Call XoaDongTrong End Sub Sub XoaDongTrong() Dim Arr(), ArrKQ(1 To 60000, 1 To 2) Dim i As Byte, j As Byte, s As Byte, dk As Boolean, k As Long k = Sheet1.[A65535].End(xlUp).Row Arr = Sheet1.[A2].Resize(k - 1, 2).Value s = 0 For i = 1 To UBound(Arr()) dk = False For j = 1 To 2 If Arr(i, j) <> "" Then dk = True Next If dk = True Then s = s + 1 For j = 1 To 2 ArrKQ(s, j) = Arr(i, j) Next End If Next With Sheet1.[A2] .Resize(k - 1, 2).ClearContents .Resize(s, 2) = ArrKQ End With End Sub
Dim SrcRng as Range
Private Sub UserForm_Initialize()
Set SrcRng = Sheet1.Range([A2], Sheet1.[B65536].End(xlUp))
.......
End Sub
Private Sub UserForm_Terminate()
SrcRng.SpecialCells(4).Delete 2
End Sub
For i = 1 To UBound(Arr())
dk = False
For j = 1 To 2
If Arr(i, j) <> "" Then dk = True
Next
If dk = True Then
For i = 1 To UBound(Arr())
If Arr(i, 1) & Arr(i, 2) <> "" Then
s = s + 1
For j = 1 To 2
ArrKQ(s, j) = Arr(i, j)
Next
s = s + 1
ArrKQ(s, 1) = Arr(i, 1): ArrKQ(s, 2) = Arr(i, 2)
Private Sub XoaDongTrong()
On Error Resume Next
Set Rng = Range(Sheet1.[A2], Sheet1.[B65535].End(xlUp))
Rng.SpecialCells(4).Delete 2
End Sub
Thì đoạn này .Resize(j, 2) = ArrKQ nó gán Value xuống sheet, lấy đâu mà còn công thứcCòn một thắc mắc nữa là khi sử dụng công thức trong hàng, khi xóa hàng những công thức sẽ không còn nữa, chỉ còn lại Value. Chắc kiểu của nó là vậy!
Cám ơn Thầy PTM, nhờ Thầy mà em đã sửa lại code ngắn gọn hơn rất nhiều, không lủng củng và nhiều vòng lặp, chạy tốt hơn.
PHP:Sub XoaDongTrong() Dim Arr(), ArrKQ k = Sheet1.[A65535].End(xlUp).Row ReDim ArrKQ(1 To k, 1 To 2) Arr = Sheet1.[A2].Resize(k - 1, 2).Value j = 0 For i = 1 To UBound(Arr()) If Arr(i, 1) & Arr(i, 2) <> "" Then j = j + 1 ArrKQ(j, 1) = Arr(i, 1) ArrKQ(j, 2) = Arr(i, 2) End If Next With Sheet1.[A2] .Resize(k - 1, 2).ClearContents .Resize(j, 2) = ArrKQ End With End Sub
Còn mục số 3 nữa:
Dim Arr(), ArrKQ
k = Sheet1.[A65535].End(xlUp).Row
ReDim ArrKQ(1 To k, 1 To 2)
...
Sub XoaDongTrong()
Dim Arr(), ArrKQ
k = Sheet1.[A65535].End(xlUp).Row
ReDim ArrKQ(1 To k, 1 To 2)
Arr = Sheet1.[A2].Resize(k - 1, 2).Value
j = 0
For i = 1 To UBound(Arr())
If Arr(i, 1) & Arr(i, 2) <> "" Then
j = j + 1
ArrKQ(j, 1) = Arr(i, 1)
ArrKQ(j, 2) = Arr(i, 2)
End If
Next
With Sheet1.[A2]
.Resize(k - 1, 2).ClearContents
.Resize(j, 2) = ArrKQ
End With
End Sub
Đưa file có công thức lên đây đi chứThầy kiểm tra dùm xem, cái này (Rng.SpecialCells(4).Delete 2) nó cũng không còn công thức!
Option Explicit
Dim lsvItem As ListItem
Dim i As Long, j As Long, k As Long
Dim SrcRng As Range
''------------------------------------------------------------------------
Private Sub UserForm_Initialize()
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
Call FillDefault
Set SrcRng = Sheet1.Range([A2], Sheet1.[B65536].End(xlUp))
With ListView1
.ColumnHeaders.Clear: .ListItems.Clear
For i = 1 To 2
.ColumnHeaders.Add , , Sheet1.Cells(1, i), 130
Next
.ColumnHeaders.Add , , "LINE", 0
For j = 1 To Sheet1.[A65535].End(xlUp).Row - 1
Set lsvItem = .ListItems.Add(, , Sheet1.Cells(j + 1, "A"))
For k = 1 To 2
Select Case k
Case 2: lsvItem.SubItems(k) = Format(Cells(j + 1, k + 1).Row, "00000")
Case Else: lsvItem.SubItems(k) = Sheet1.Cells(j + 1, k + 1)
End Select
Next k, j
End With
End Sub
''------------------------------------------------------------------------
Private Sub FillDefault()
With Sheet1
.[A2].Value = "HTN0001"
.[B2].Value = "HOANG TRONG NGHIA 0001"
.[A2:B2].AutoFill Destination:=.[A2:B2001], Type:=xlFillDefault
End With
End Sub
'------------------------------------------------------------------------
Private Sub UserForm_Terminate()
On Error Resume Next
SrcRng.SpecialCells(4).Delete 2
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
Private Sub CommandButton1_Click()
With CommandButton1
For Each lsvItem In Me.ListView1.ListItems
lsvItem.Checked = .Caption = "Check ALL"
Next
.Caption = IIf(.Caption = "Check ALL", "UnCheck ALL", "Check ALL")
End With
End Sub
'------------------------------------------------------------------------
Private Sub CommandButton2_Click()
With ListView1
For i = .ListItems.Count To 1 Step -1
If .ListItems(i).Checked Then
j = .ListItems(i).ListSubItems(2)
Sheet1.Range("A" & j, "B" & j).ClearContents
.ListItems.Remove i
End If
Next
End With
End Sub
Private Sub ListView1_ColumnClick(ByVal ColumnHeader As MSComctlLib.ColumnHeader)
Call ListViewSort(ListView1, ColumnHeader)
End Sub
'------------------------------------------------------------------------
Private Sub ListViewSort(mLView As ListView, ByVal ColumnHeader As MSComctlLib.ColumnHeader)
With mLView
.Sorted = True
.SortKey = ColumnHeader.SubItemIndex
If .SortOrder = lvwDescending Then
.SortOrder = lvwAscending
Else
.SortOrder = lvwDescending
End If
.Sorted = False
End With
End Sub
Private Sub CommandButton2_Click()
Dim Rs As String, j
With ListView1
For i = .ListItems.Count To 1 Step -1
If .ListItems(i).Checked Then
j = .ListItems(i).ListSubItems(2)
Rs = IIf(Len(ds) = 0, j & ":" & j, ds & "," & j & ":" & j)
.ListItems.Remove i
End If
Next
End With
Sheet1.Range(Rs).Delete
End Sub
Cách của các bạn vẫn chưa gọn (Nãy giờ bận không tham gia được)
Code gộp thế này thôi,
Mã:Private Sub CommandButton2_Click() Dim Rs As String, j With ListView1 For i = .ListItems.Count To 1 Step -1 If .ListItems(i).Checked Then j = .ListItems(i).ListSubItems(2) Rs = IIf(Len(ds) = 0, j & ":" & j, ds & "," & j & ":" & j) .ListItems.Remove i End If Next End With Sheet1.Range(Rs).Delete End Sub
Theo dỏi từ đầu đến giờ mà tôi vẫn không hiểu vỉ nguyên nhân gì Learning_Excel phải dùng Listview... Còn tôi thì thà dùng Listbox, cao cấp hơn, dùng luôn SpreadSheet cho nó ngon vì mọi thao tác y chang như trên sheet
Listview chả thấy ngon chổ nào (trừ khả năng DrapDrop)
(Đương nhiên, khi quyết định dùng 1 Control nào đó, ta phải thấy được tính ưu việt của nó mà các Control khác không có)
- Nếu chỉ vì nó giống như giao diện của Worksheet mà ta không xài thì.. hơi buồn cười ---> Phải chọn Control nó khác đi cho người ta không biết mình làm cái gì chăng?Còn SpreadSheet cũng hay, nhưng do em không biết khai thác tốt nên khi cho vào form thì lại có cảm giác làm trên sheet, như vậy thà làm trong sheet tốt hơn, vã lại em không thích nó hiện cả đống control (tool box, menu) trên đó.
Nói chung do sở thích của mỗi người, nhưng cũng chẳng phải em làm chương trình gì lớn lao, chỉ là học và biết cách sử dụng từng control trong Form thôi ạ.
1. For thừa:
Tại sao không làm vầy:PHP:For i = 1 To UBound(Arr()) dk = False For j = 1 To 2 If Arr(i, j) <> "" Then dk = True Next If dk = True Then
Khỏi biến dk, khỏi dùng 100 vòng lặp conPHP:For i = 1 To UBound(Arr()) If Arr(i, 1) & Arr(i, 2) <> "" Then
2. Còn cái này:
sao không phải là:PHP:s = s + 1 For j = 1 To 2 ArrKQ(s, j) = Arr(i, j) Next
3. Khai báo ArrKQ thừa kích thước:PHP:s = s + 1 ArrKQ(s, 1) = Arr(i, 1): ArrKQ(s, 2) = Arr(i, 2)
Đã tính k = Sheet1.[A65535].End(xlUp).Row
thì khai báo ArrKQ tối đa bằng k dòng 2 cột thôi, khai báo làm gì 60 ngàn dòng!
60 ngàn dòng, dư vẫn dư, mà thiếu vẫn thiếu!
Private Sub NoBlank()
Dim i As Long, j As Long, vong As Long
Dim k As Long, dk As Boolean, Arr(), ArrKQ
k = Sheet1.[A65535].End(xlUp).Row - 2
ReDim ArrKQ(1 To k, 1 To 12)
Arr = Sheet1.[A3].Resize(k, 12).Value
vong = 0
For i = 1 To k
dk = False
For j = 1 To 12
If Arr(i, j) <> "" Then dk = True
Next
If dk = True Then
vong = vong + 1
For j = 1 To 12
ArrKQ(vong, j) = Arr(i, j)
Next
End If
Next
With Sheet1.[A3]
.Resize(k, 12).ClearContents
.Resize(vong, 12) = ArrKQ
End With
End Sub
Private Sub CommandButton1_Click()
With CommandButton1
If .Caption = "No Blank" Then Call NoBlank Else Call Temp
.Caption = IIf(.Caption = "No Blank", "Temp", "No Blank")
End With
End Sub
'---------------------------------------------------------
Private Sub Temp()
Sheet2.[A3:L43].Copy Sheet1.[A3]
End Sub
Xét về mặt giải thuật thì cũng tạm ổn nhưng xét về bố cục để "vận hành" giải thuật trên thì... hơi dởVới bài này, tôi dùng 12 cột trong 1 bảng tính và dùng nhiều vòng lặp, với mong muốn là được mọi người chỉ dẫn thêm để cải thiện việc học về vòng lặp.
Tôi sử dụng code như sau:
(Vì đã có k nên tôi không dùng For i = 1 To UBound(Arr()) nữa mà chỉ dùng For i = 1 To k)
PHP:Private Sub NoBlank() Dim i As Long, j As Long, vong As Long Dim k As Long, dk As Boolean, Arr(), ArrKQ k = Sheet1.[A65535].End(xlUp).Row - 2 ReDim ArrKQ(1 To k, 1 To 12) Arr = Sheet1.[A3].Resize(k, 12).Value vong = 0 For i = 1 To k dk = False For j = 1 To 12 If Arr(i, j) <> "" Then dk = True Next If dk = True Then vong = vong + 1 For j = 1 To 12 ArrKQ(vong, j) = Arr(i, j) Next End If Next With Sheet1.[A3] .Resize(k, 12).ClearContents .Resize(vong, 12) = ArrKQ End With End Sub
PHP:Private Sub CommandButton1_Click() With CommandButton1 If .Caption = "No Blank" Then Call NoBlank Else Call Temp .Caption = IIf(.Caption = "No Blank", "Temp", "No Blank") End With End Sub '--------------------------------------------------------- Private Sub Temp() Sheet2.[A3:L43].Copy Sheet1.[A3] End Sub
Sub RemoveBlanksRow()
Dim SrcArr, DesArr, i As Long, j As Long, lRow As Long, k As Long
SrcArr = Sheet1.UsedRange.Value
ReDim DesArr(1 To UBound(SrcArr, 1), 1 To UBound(SrcArr, 2))
For i = 1 To UBound(SrcArr, 1)
lRow = lRow + 1: k = 0
For j = 1 To UBound(SrcArr, 2)
If SrcArr(i, j) = "" Then k = k + 1
DesArr(lRow, j) = SrcArr(i, j)
Next
If k = UBound(SrcArr, 2) Then lRow = lRow - 1
Next
Sheet1.UsedRange.Value = DesArr
End Sub
Function RemoveBlanksRow(ByVal SrcRng As Range)
Dim SrcArr, DesArr, i As Long, j As Long, lRow As Long, k As Long
On Error GoTo ExitFunc
RemoveBlanksRow = SrcRng.Value
SrcArr = SrcRng.Value
RemoveBlanksRow = SrcArr
ReDim DesArr(1 To UBound(SrcArr, 1), 1 To UBound(SrcArr, 2))
For i = 1 To UBound(SrcArr, 1)
lRow = lRow + 1: k = 0
For j = 1 To UBound(SrcArr, 2)
If SrcArr(i, j) = "" Then k = k + 1
DesArr(lRow, j) = SrcArr(i, j)
Next
If k = UBound(SrcArr, 2) Then lRow = lRow - 1
Next
RemoveBlanksRow = DesArr
ExitFunc:
End Function
Sub Main()
With Sheet1.UsedRange
.Value = RemoveBlanksRow(.Cells)
End With
End Sub