Những câu hỏi về code, xin giải thích các code, đề nghị các bạn gửi vào đây (2 người xem)

[ST-Lu!]

Kể từ hôm nay, tất cả những câu hỏi nhờ giải thích dùm một đoạn code, hay là hỏi những vấn đề linh tinh gì liên quan đến cách viết code, đề nghị các bạn gửi chung vào đây.

Những đề tài mới với tiêu đề: "Nhờ giải thích dùm đoạn code", mà không nói rõ là code gì, code dùng để làm gì, sẽ bị xóa.

BQT
----------------------------------------------------------------------------------------------------------------


Em xin được hỏi 2 đoạn code sau có tương đương nhau ?

Cells(Cells.Rows.Count, 1).End(xlUp).Row có tương đương với [A65000].End(xlup).row

Cám ơn các anh chỉ giáo

 

[thanhtam348]

Đã thỏa mãn rồi. Cám ơn ndu96081631.

 

[thanhtam348]

Xin ndu96081631 vui lòng giúp cho lần nửa.
Cũng trong file đó mình muốn tạo 1 Form nhập liệu đơn giản gồm có mã hàng và tên hàng, để tiện khi mặt hàng nào không có trong DS mình có thể gọi Form nhập vào và lưu qua Sheet "Link DS" cho tiện hơn.
Cám ơn ndu96081631.

 

[ndu96081631]

Xin ndu96081631 vui lòng giúp cho lần nửa.
Cũng trong file đó mình muốn tạo 1 Form nhập liệu đơn giản gồm có mã hàng và tên hàng, để tiện khi mặt hàng nào không có trong DS mình có thể gọi Form nhập vào và lưu qua Sheet "Link DS" cho tiện hơn.
Cám ơn ndu96081631.

Bạn tự thiết kế cái form ấy trước đi, có rồi hãy đưa lên đây để nghiên cứu nhé
(Nói xin lỗi, viết code tôi không ngại, nhưng thiết kế form thì ngại vô cùng)

 

[thanhtam348]

Gặp lại ndu96081631 và lại làm phiền nửa.
Dùm giúp mình - gợi ý nằm trong File đính kèm. Cam Ơn.

 

[tuan055815671]

Cho em hỏi mấy anh có ai biết làm sao viết đoạn code: khi nào mà em click chuột vào ô B100 thì lập tức cột B hàng 100 sẽ đổi màu sang màu xanh không?
anh chị cố gắng giúp em!

 

[ndu96081631]

Cho em hỏi mấy anh có ai biết làm sao viết đoạn code: khi nào mà em click chuột vào ô B100 thì lập tức cột B hàng 100 sẽ đổi màu sang màu xanh không?
anh chị cố gắng giúp em!

Tìm trên diễn đàn từ khóa HighLight ---> Có cả đóng

 

[nmhung49]

Em có 2 đoạn code dùng để hiện những sheet bị ẩn. Giả su em co 10 sheets

sub unhidesheet()
dim i as byte
for i = 1 to 10
sheet & i .visible = true
' thì bị lỗi
next i
end sub

nhưng e thử từ sheet một ví dụ sheet1.visble = true thì ok

Sub UnHideSheet()
Dim sh As Worksheet
   For Each sh In ThisWorkbook.Worksheets
       sh.Visible = True
   Next sh
End Sub

Đoạn code trên thì rất ok, mong anh chị giải thích giúp em đoạn code đầu tiên tai sao bị lỗi

 

[ndu96081631]

Em có 2 đoạn code dùng để hiện những sheet bị ẩn. Giả su em co 10 sheets

sub unhidesheet()
dim i as byte
for i = 1 to 10
sheet & i .visible = true
' thì bị lỗi
next i
end sub

nhưng e thử từ sheet một ví dụ sheet1.visble = true thì ok

Sub UnHideSheet()
Dim sh As Worksheet
   For Each sh In ThisWorkbook.Worksheets
       sh.Visible = True
   Next sh
End Sub

Đoạn code trên thì rất ok, mong anh chị giải thích giúp em đoạn code đầu tiên tai sao bị lỗi

Phải vầy chứ

Sub Unhidesheet()
  Dim i As Long
  For i = 1 To Sheets.Count
    Sheets(i).Visible = True
  Next i
End Sub

 

[ChanhTQ@]

Bạn hãy tự tìm ra kết luận nha

Em có 2 đoạn code dùng để hiện những sheet bị ẩn. Giả su em co 10 sheets

sub unhidesheet()
dim i as byte
for i = 1 to 10
sheet & i .visible = true
' thì bị lỗi
next i
end sub

Option Explicit
Sub UnHideSheet()
Dim jJ As Byte
For jJ = 1 To 10
   MsgBox Sheets("sheet" & jJ).Name
Next jJ
End Sub

(*) Mà sao bạn ngại xài chữ hoa nhỉ? - Thấy không, mình xài vầy có ai cấm cản gì đâu & trong cũng dễ chịu ấy chứ, nhỉ?

 

[nmhung49]

Cách anh Ndu là tuyệt cú mèo và đúng ý em vì khi đổi tên sheet thì cách đoá vẫn đúng, còn cách anh ChanhTQ thì bị lỗi nếu em đổi tên sheet. Thanks 2 anh nhiều

 

[phamtrangnb]

Các Anh, chị ơi! làm sao để ẩn các dòng trống một cách nhanh nhất

 

[atpgd]

Các bác giúp em với em khong biết cho gửi câu hỏi ở đâu
em muốn khi em nhập tên đơn vị vào một ô nào đó trong sheet thì tên file sẽ được đổi theo tên ô đó
các bác giúp em với

 

[ndu96081631]

Các bác giúp em với em khong biết cho gửi câu hỏi ở đâu
em muốn khi em nhập tên đơn vị vào một ô nào đó trong sheet thì tên file sẽ được đổi theo tên ô đó
các bác giúp em với

Tức là đổi tên file cho chính mình
Không đơn giản à nha!
Theo tôi thì thuật toán có thể là:
- SaveAs file thành 1 file mới (theo tên bạn đã gõ tại cell nào đó)
- Xóa file cũ
Đại khái thế này:

Private Sub Worksheet_Change(ByVal Target As Range)
  Dim OldName As String, NewName As String
  On Error Resume Next
  If Target.Address = "$A$1" Then
    OldName = ThisWorkbook.FullName
    NewName = ThisWorkbook.Path & "\" & Target & ".xls"
    Application.DisplayAlerts = False
    ThisWorkbook.SaveAs NewName
    Kill OldName
    Application.DisplayAlerts = True
  End If
End Sub

 

[boyxin]

Tức là đổi tên file cho chính mình
Không đơn giản à nha!
Theo tôi thì thuật toán có thể là:
- SaveAs file thành 1 file mới (theo tên bạn đã gõ tại cell nào đó)
- Xóa file cũ
Đại khái thế này:

Private Sub Worksheet_Change(ByVal Target As Range)
  Dim OldName As String, NewName As String
  On Error Resume Next
  If Target.Address = "$A$1" Then
    OldName = ThisWorkbook.FullName
    NewName = ThisWorkbook.Path & "\" & Target & ".xls"
    Application.DisplayAlerts = False
    ThisWorkbook.SaveAs NewName
    Kill OldName
    Application.DisplayAlerts = True
  End If
End Sub

Nếu tên File có dấu tiếng việt thì khi đổi tên thành file mới, file cũ không bị xoá

Khi bỏ dòng: On Error Resume Next
Nếu tên File (OldName) có dấu tiếng việt thì câu lệnh Kill OldName báo lỗi

Run-time error '53'
File not found

@ndu96081631: Có cách nào khắc phục lỗi này không?

 

[ndu96081631]

Nếu tên File có dấu tiếng việt thì khi đổi tên thành file mới, file cũ không bị xoá

Khi bỏ dòng: On Error Resume Next
Nếu tên File (OldName) có dấu tiếng việt thì câu lệnh Kill OldName báo lỗi

@ndu96081631: Có cách nào khắc phục lỗi này không?

Cái vụ tên file là tiếng Việt luôn luôn là thứ gây rối khi xử lý file... nhưng Scripting.FileSystemObject nó chơi được tuốt
Thay:

Kill OldName

thành:

CreateObject("Scripting.FileSystemObject").DeleteFile OldName

thử xem

 

[boyxin]

Cái vụ tên file là tiếng Việt luôn luôn là thứ gây rối khi xử lý file... nhưng Scripting.FileSystemObject nó chơi được tuốt
Thay:

Kill OldName

thành:

CreateObject("Scripting.FileSystemObject").DeleteFile OldName

thử xem

Hi, Như vậy ngon rồi. Thank

Lại hỏi thêm chút xíu nữa:

Khi Export File ... được file *.cls
Khi Import File ... thì nó vào Class Module

Vấn đề: Để code đó ở Class Module thì làm thế nào Code đó hoạt động? (chắc phải copy or cut and paste in sheet ...)

 

[ndu96081631]

Hi, Như vậy ngon rồi. Thank

Lại hỏi thêm chút xíu nữa:

Khi Export File ... được file *.cls
Khi Import File ... thì nó vào Class Module

Vấn đề: Để code đó ở Class Module thì làm thế nào Code đó hoạt động? (chắc phải copy or cut and paste in sheet ...)

Nếu muốn chơi trò "Import/Export" tôi nghĩ nên dùng Class Event thì hay hơn
Thay vì viết code trong sheet, ta viết code trong Class Module như sau:

Public WithEvents fn As Worksheet
Private Sub fn_Change(ByVal Target As Range)
  Dim OldName As String, NewName As String
  On Error Resume Next
  If Target.Address = "$A$1" Then
    OldName = ThisWorkbook.FullName
    NewName = ThisWorkbook.Path & "\" & Target & ".xls"
    Application.DisplayAlerts = False
    ThisWorkbook.SaveAs NewName
    CreateObject("Scripting.FileSystemObject").DeleteFile OldName
    Application.DisplayAlerts = True
  End If
End Sub

Khi này, nếu Export ta sẽ được 1 file *.cls và khi Import thì đương nhiên nó sẽ vào đúng Class Module như nguyên mẫu
Để kích hoạt cho Class Module này hoạt động, chỉ cần Autpen thế này:

Dim Ws As New Class1
Sub Auto_Open()
  Set Ws.fn = Sheet1
End Sub

Cũng có thể Export luôn Module chứa sub Autpen, ta được file *.bas ---> Khi Import, ta import 1 lúc 2 món: Class và Module
Bạn thử xem

 

[boyxin]

Nếu muốn chơi trò "Import/Export" tôi nghĩ nên dùng Class Event thì hay hơn
Thay vì viết code trong sheet, ta viết code trong Class Module như sau:

Public WithEvents fn As Worksheet
Private Sub fn_Change(ByVal Target As Range)
  Dim OldName As String, NewName As String
  On Error Resume Next
  If Target.Address = "$A$1" Then
    OldName = ThisWorkbook.FullName
    NewName = ThisWorkbook.Path & "\" & Target & ".xls"
    Application.DisplayAlerts = False
    ThisWorkbook.SaveAs NewName
    CreateObject("Scripting.FileSystemObject").DeleteFile OldName
    Application.DisplayAlerts = True
  End If
End Sub

Khi này, nếu Export ta sẽ được 1 file *.cls và khi Import thì đương nhiên nó sẽ vào đúng Class Module như nguyên mẫu
Để kích hoạt cho Class Module này hoạt động, chỉ cần Autpen thế này:

Dim Ws As New Class1
Sub Auto_Open()
  Set Ws.fn = Sheet1
End Sub

Cũng có thể Export luôn Module chứa sub Autpen, ta được file *.bas ---> Khi Import, ta import 1 lúc 2 món: Class và Module
Bạn thử xem

Thật tuyệt vời. thank you very much

 

[ngondenthu9]

Để xem code của một đoạn chương trình trong excel thì phải vào đâu để xem. Xin Cảm ơn

 

[thanhlanh]

Bạn hỏi không rõ, vào Tools->Macro->Visual Basic Editor hoặc bấm Alt + f11 thử đúng ý bạn không.

 

[kienza]

các bạn giúp mình cách viết đúng đoạn code này với

mình dùng VBA soan 1 bài test trên Powerpoint gặp phải 1 vướng mắc

bt` phần bài trắc nghiệm mình ra thì chỉ cần kích chuột vào ô chấm điển là ok

Private Sub Chamdiem_Click()
Diem.Caption = "0"
If C1.Caption = L2.Caption Then Diem.Caption = Diem.Caption + 1
If C2.Caption = L7.Caption Then Diem.Caption = Diem.Caption + 1
If C3.Caption = L1.Caption Then Diem.Caption = Diem.Caption + 1
If C4.Caption = L3.Caption Then Diem.Caption = Diem.Caption + 1
If C5.Caption = L4.Caption Then Diem.Caption = Diem.Caption + 1
If C6.Caption = L6.Caption Then Diem.Caption = Diem.Caption + 1
If C7.Caption = L5.Caption Then Diem.Caption = Diem.Caption + 1
If Diem.Caption = "7" Then G.Caption = " CHUÙC MÖØNG BAÏN ÑAÕ HOAØN THAØNH XUAÁT SAÉC"
If Diem.Caption = "6" Then G.Caption = " 6/7 BAÏN TÌM RA CHOÃ SAI ROÀI CHÖÙ "
If Diem.Caption = "5" Then G.Caption = " 5/7 THÖÛ XEM LAÏI XEM BAÏN NHAÀM ÔÛ CHOÃ NAØO "
If Diem.Caption = "4" Then G.Caption = " 4/7 KIEÁN THÖÙC CUÛA BAÏN CHÖA ÑÖÔÏC CHAÉC LAÉM"
If Diem.Caption = "3" Then G.Caption = " 3/7 CHAÉC BAÏN CHÖA QUEN VÔÙI CAÙCH ÑIEÀN NAØY"
If Diem.Caption = "2" Then G.Caption = " 2/7 CHAÉC BAÏN CHÖA QUEN VÔÙI CAÙCH ÑIEÀN NAØY"

End Sub

mình có dùng VBA tạo 1 cái đồng hồ đếm ngược và muốn rằng khi nó đếm lùi về tới 0 ( txtSecond.Value = "0" ) thì sẽ tự động chấm điểm như khi mình kích vào ô chấm điểm,
các bạn bớt chút thời gian hướng dẫn mình nhé
thanks các bạn trước !!!

 

[kienza]

ai giúp mình với
_______________________________

 

[win-sun]

Em xin hỏi các cao thủ code nào mà từ sheet 1 ta có thể chọn các trường của pivot table ở sh2, mỗi khi muốn chọn phải sang sh hơi chậm, xin cảm ơn

 

[ndu96081631]

Em xin hỏi các cao thủ code nào mà từ sheet 1 ta có thể chọn các trường của pivot table ở sh2, mỗi khi muốn chọn phải sang sh hơi chậm, xin cảm ơn

Record macro quá trình chọn "trường", nó ra thế này

Sub Macro1()
'
' Macro1 Macro
' Macro recorded 29/8/2010 by ndu
'

'
    ActiveSheet.PivotTables("PivotTable1").PivotFields("THÁNG").CurrentPage = "TH2"
End Sub

Vậy thì viết code cho sheet1 như sau:

Private Sub Worksheet_Change(ByVal Target As Range)
  If Target.Address = "$C$2" Then
    [COLOR=Red][B]Sheet2[/B][/COLOR].PivotTables("PivotTable1").PivotFields("[COLOR=Blue][B]THÁNG[/B][/COLOR]").CurrentPage = [B][COLOR=Red]Target.Value[/COLOR][/B]
  End If
End Sub

Chú ý chổ màu đỏ chính là chổ mà ta đã tùy biến từ code gốc
Ngoài ra chứ ý 1 vụ quan trong ---> Chổ màu xanh là tiếng Việt có dấu ---> Coi chừng sẽ chẳng biết phải ghi thế nào (ví dụ PivotFields("ÔNG NỘI") ...)

 

[ntxuyen]

Code tự động Enable Macro

Chào các anh/chị
Mình đang cần code: mà khi mở file excel, tự động enable macro để khi mình gửi file có macro cho Sếp mà Sếp không phải Enable Macro. Anh/Chị nào biết chỉ dùm mình với. Mình tìm mãi không ra. Cám ơn rất nhiều

 

[thothongcong]

Nhờ giải thích giùm ý nghĩa đoạn code !
chào các pác!!
em chỉ mới tìm hiểu về vb nên có một số đoạn code cũng như ý nghĩa của nó cũng chưa hiểu lắm mong các pác chỉ giáo thêm cho em
1) .CurrentRegion.Resize(, 1).SpecialCells(2, 1).Value = Evaluate("ROW(R:R)")
2) m = S02.Range("C65000").End(xlUp).Row
Range("B6:C" & m).Select
Selection.Sort Key1:=Range("B6"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
ý nghĩa từng đoạn code ?, ý nghĩa (nếu càng chi tiết thì càng ok ) của câu lệnh được tô đậm
thanks các pác nhìu!!!!!!!!

 

[thothongcong]

Nhờ giải thích giùm ý nghĩa đoạn code !

chào các pác!!
em chỉ mới tìm hiểu về vb nên có một số đoạn code cũng như ý nghĩa của nó cũng chưa hiểu lắm mong các pác chỉ giáo thêm cho em
1) .CurrentRegion.Resize(, 1).SpecialCells(2, 1).Value = Evaluate("ROW(R:R)")
2) m = S02.Range("C65000").End(xlUp).Row
Range("B6:C" & m).Select
Selection.Sort Key1:=Range("B6"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
ý nghĩa từng đoạn code ?, ý nghĩa (nếu càng chi tiết thì càng ok ) của câu lệnh được tô đậm
thanks các pác nhìu!!!!!!!!
​

 

[hovanlai1604]

cho mình hỏi các bạn tí nhé:
tại sao mình viết đoạn code đếm những ô kiểu bold (in đậm) thì được mà đếm kiểu underline (gạch chân) thì không được.
Xin chỉ giùm với

Sub NoBold()
Dim lcolumn As Long, cot As Long, i As Long, t As Byte
lcolumn = 4
t = 0
cot = 1
Do While cot <= lcolumn
Do While Cells(1, cot).Font.underline = True {nếu thay underline bằng bold thì đếm được)
t = t + 1
cot = cot + 1
Loop
cot = cot + 1
If cot > lcolumn Then Exit Do
Loop
Cells(1, cot) = t
End Sub

Đây là đoạn code đếm số ô gạch chân trong excel
Nếu thay kiểu underline (gạch chân) bằng kiểu bold (in đậm) thì đếm được. Nhưng đếm kiểu underline thì lại không được
mong mọi người chỉ giùm

Sub NoBold()
 Dim lcolumn As Long, cot As Long, i As Long, t As Byte
 lcolumn = 4
 t = 0
 cot = 1
  Do While cot <= lcolumn
    Do While Cells(1, cot).Font.underline = True
        t = t + 1
        cot = cot + 1
    Loop
    cot = cot + 1
    If cot > lcolumn Then Exit Do
 Loop
 Cells(1, cot) = t
End Sub

 

[concogia]

Đây là đoạn code đếm số ô gạch chân trong excel
Nếu thay kiểu underline (gạch chân) bằng kiểu bold (in đậm) thì đếm được. Nhưng đếm kiểu underline thì lại không được
mong mọi người chỉ giùm

Sub NoBold()
Dim lcolumn As Long, cot As Long, i As Long, t As Byte
lcolumn = 4
t = 0
cot = 1
Do While cot <= lcolumn
Do While Cells(1, cot).Font.underline = True
t = t + 1
cot = cot + 1
Loop
cot = cot + 1
If cot > lcolumn Then Exit Do
Loop
Cells(1, cot) = t
End Sub

Thử thay:
Do While Cells(1, cot).Font.underline = True
Bằng
Do While Cells(1, cot).Font.Underline = xlUnderlineStyleSingle
Tùy thuộc vào định dạng "thằng" gạch chân (xlUnderlineStyleSingle, xlUnderlineStyleDouble .....)

 

[ndu96081631]

cho mình hỏi các bạn tí nhé:
tại sao mình viết đoạn code đếm những ô kiểu bold (in đậm) thì được mà đếm kiểu underline (gạch chân) thì không được.
Xin chỉ giùm với

Code của bạn sao dài dòng thế nhỉ? Sao không For Each... Next cho nó khỏe
Kiểu vầy nè:

Function CountUnderline(sRange As Range) As Long
  Dim Clls As Range
  Application.Volatile
  For Each Clls In sRange
    If Clls.Font.Underline > -4142 Then _
      CountUnderline = CountUnderline + 1
  Next
End Function

 

[vanhesing]

Nhờ sữa giùm mình code của ví dụ sau

khi mình search tên chi nhánh / nhân viên ở ô E 5 của sheet CongNo thì nó chỉ ra được dữ liệu được nhập lần đầu tiên (những dòng đầu) ở sheet da ta thì nó ra đúng. nhưng nếu nhập dữ liệu tiếp theo cho sheet da ta ở những dòng tiếp theo với 1 tên chi nhánh/ nhân viên khác thì nó ko ra .
Mình ko biết code sai ở chổ nào , mình nghỉ nó bị giới hạn số dòng nhưng mình đã sữa vẫn không được .
Mong các cao nhân chỉ ra chổ sai giùm (mình đang học VBA chập chững nên còn gà lắm )
thanks!!1
SORY MÌNH POST LỘN BÀI , CÁC BẠN VÀO FILE CongNo-Ver03-3.rar NHA
GIÚP GIÙM LẦN NỮA
THANKS

 

[Thanh Tu 123]

Xin các bạn viết dùm code loc dữ liệu từ nhật ký chung sang sổ cái tài khoản. Chân Thành cảm ơn

 

[dth_hn]

Xin mọi người giúp đỡ về lỗi code này
Recordset.Sort = "ID"
Thông báo lỗi:
Run-time error '3251':
Current provider does not support the necessary interfaces for sorting or filtering

Mình đang viết một đoạn code trong excel có làm việc với dữ liệu mdb. Nhưng khi tạo một Recordset xong và muốn sort thứ tự thì không được.
Provider đã khai báo là:
Set Connection = New ADODB.Connection
Cnct = "Provider=Microsoft.Jet.OLEDB.4.0; " & _
"Data Source=" & DBFullName & ";"
Connection.Open ConnectionString:=Cnct
hoặc là:
Cnct = "Driver={Microsoft Access Driver (*.mdb)}; " & _
"Dbq=" & DBFullName
Connection.Open Cnct
cả hai cái này cũng đều không được. Trong reference đã để là Microsoft ActiveX data objects 2.5 library rồi

 

[huonghuyenxinh]

Các bạn ơi!
Giúp mình chút với
Mình muốn học về macro mà không sao hiểu được.Mình không biết đọc và hiểu ý nghĩa của code như thế nào.Nó mơ hồ quá.Bạn nào có thể giúp mình không?
Cảm ơn rất nhiều!

 

[nonut]

Các bác giúp em với, em đang làm cái shortcut đơn giản cho cái lệnh làm Autofit độ dài của Column, nhưng chỉ Autofit cho cái cột mà em đang làm việc thôi, sử dụng chức năng record macro thì nó cho như sau:

Sub Auto_fit_column()
'
' Auto_fit_column Macro
' Auto fit column
'
' Keyboard Shortcut: Ctrl+Shift+L
'
    Columns("A:A").EntireColumn.AutoFit
End Sub

Bác nào giúp em sửa lệnh sao cho nó chỉ Autofit đúng cái dòng của Cell mà mình đang chọn thôi.

Cám ơn các bác nhiều.

 

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

Các bác giúp em với, em đang làm cái shortcut đơn giản cho cái lệnh làm Autofit độ dài của Column, nhưng chỉ Autofit cho cái cột mà em đang làm việc thôi, sử dụng chức năng record macro thì nó cho như sau:

Sub Auto_fit_column()
'
' Auto_fit_column Macro
' Auto fit column
'
' Keyboard Shortcut: Ctrl+Shift+L
'
    [COLOR=Red]Columns("A:A")[/COLOR].EntireColumn.AutoFit
End Sub

Bác nào giúp em sửa lệnh sao cho nó chỉ Autofit đúng cái dòng của Cell mà mình đang chọn thôi.

Cám ơn các bác nhiều.

Bạn chỉnh cái đỏ đỏ ở trên nhé. Đó là cột A

ActiveCell.EntireColumn.AutoFit

 

[NH_DK]

Sửa dùm em đoạn code sai

A/C vui lòng sửa dùm em code sai sao cho nhập liệu được nhé!

Private Sub CommandButton1_Click()
Dim iRow As Long
Dim ws As Worksheet
Set ws = Worksheets("DATA")
iRow = ws.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
    If Trim(Me.TextBox2.Value) = "" Then
        Me.TextBox2.SetFocus
        MsgBox "Ho va ten khong duoc bo trong", vbCiritial + vbOKOnly
    Exit Sub
    End If
ws.Cells(iRow, 1).Value = Me.TextBox1.Value '' Dòng này sai chỗ nào?
ws.Cells(iRow, 2).Value = Me.TextBox2.Value
ws.Cells(iRow, 3).Value = Me.TextBox3.Value
ws.Cells(iRow, 4).Value = Me.TextBox4.Value
Me.TextBox1.Value = ""
Me.TextBox2.Value = ""
Me.TextBox3.Value = ""
Me.TextBox4.Value = ""
End Sub

Cám ơn A/C nhiều!

 

[ChanhTQ@]

Dòng đó không sai chổ nào hết!

Bạn sai ở dòng trên; Nhưng nó đễu với bạn nên đến khi bạn đem cái biến đã gán sai kiểu dữ liệu nó mới báo là sai

BG đễu thật!

 iRow = ws.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)'.Row'

 

[nonut]

Em dùng record macro để tạo phím tắt tăng kích thước chữ (bằng cách ấn vào Increase Font Size button ở Tab Home).
Thay vì ấn Alt_H + FG thì ấn Ctrl + Shirt + M thì thu được code như sau:

Sub Increase_size()
'
' Increase_size Macro
' Increase font size
'
' Keyboard Shortcut: Ctrl+Shift+M
'
    Selection.Font.Size = 11
End Sub

Các bác thấy đó, nó lại chọn font là 11. Bác nào giúp em sửa code này cho nó thành tăng kích thước font với.
Tiện thể cho em thêm code để giảm kích thước font luôn càng tốt ạ.
Cám ơn các bác

 

[sep_hatxel]

Mình có đoạn code trên bản excel gốc để tìm lọc dữ liệu ở sheet1 xuất sang sheet2 nhưng với số liệu ở sheet1 chỉ có từ A1:CW100! Nay mình muốn sửa lại đoạn code để có thể kiểm tra ở sheet1 với số liệu nhập nhiều hơn là A1:IV11344, nhưng mình sửa nhiều kiểu mà không ra! Rất mong GPE giúp hộ mình! Mình xin gửi kèm theo 2 File excel: 1 file gốc: số liệu ở sheet1 chỉ có trong vùng A1:CW100 và 1 file coppy mình đã nhập sẵn số liệu minh hoạ với số liệu ở sheet1 là A1:IV11344 và điều kiện tìm kết quả giống hệt như phần file gốc cũng xuất sang sheet2!
Xin chân thành cảm ơn mọi người!

Đây là đoạn mã code của bản gốc:
Dim Mang(1000, 1000) As Boolean
Sub Doc_Mang()
Dim i As Integer, j As Integer
For i = 1 To 100
For j = 1 To 100
Mang(i, j) = False
If Sheet1.Cells(i, j + 1) <> "" Then Mang(i, j) = True
Next
Next

j = 5
For i = 10000 To 5 Step -1
If Sheet2.Cells(i, 1) <> "" Then
j = i
Exit For
End If
Next
Sheet2.Range("A1:IV1").Copy
For j = 5 To i
Sheet2.Range("A" & j & ":IV" & j).PasteSpecial (xlPasteAll)
Next
End Sub
Function fKiemTra(i, j As Integer) As Boolean
Dim k As Integer
Dim KQ As Boolean
k = 1
KQ = True
Do While k < 100
If (Mang(i, k) = False) And (Mang(i, k + 1) = False) And (Mang(j, k) = False) And (Mang(j, k + 1) = False) Then
KQ = False
Exit Do
End If
k = k + 2
Loop
'MsgBox i & " - " & j & ":" & k
fKiemTra = KQ
End Function
Sub Tim_kiem()
Dim i As Integer, j As Integer
Dim TT As Integer, SR As String
Doc_Mang

TT = 5
For i = 1 To 99
For j = i + 1 To 100
If fKiemTra(i, j) = True Then
SR = "A" & i & ":CW" & i
Sheet1.Range(SR).Copy
SR = "A" & TT & ":CW" & TT
Sheet2.Range(SR).PasteSpecial (xlPasteAll)
TT = TT + 1

SR = "A" & j & ":CW" & j
Sheet1.Range(SR).Copy
SR = "A" & TT & ":CW" & TT
Sheet2.Range(SR).PasteSpecial (xlPasteAll)
TT = TT + 2
End If
Next
Next
End Sub

 

[ptm0412]

Em dùng record macro để tạo phím tắt tăng kích thước chữ (bằng cách ấn vào Increase Font Size button ở Tab Home).
Thay vì ấn Alt_H + FG thì ấn Ctrl + Shirt + M thì thu được code như sau:
...
Các bác thấy đó, nó lại chọn font là 11. Bác nào giúp em sửa code này cho nó thành tăng kích thước font với.
Tiện thể cho em thêm code để giảm kích thước font luôn càng tốt ạ.
Cám ơn các bác

Selection.Font.Size = Selection.Font.Size + 1 'Tang
Selection.Font.Size = Selection.Font.Size - 1 'Giam

 

[ChanhTQ@]

Hẵn khoan nói về code của bạn.

Hix buồn quá! Không ai giúp hộ mình! Mình hì hục mấy hôm rồi mà chưa ra!

Hãy nói bạn muốn copy dữ liệu từ trang 1 sang trang 2 với điều kiện gì;

Biết đâu làm mới sẽ hay hơn cách mà bạn đang xài cũng nên!

(Thời gian của mọi người đa số là không nhiều; mà bạn lại ít lời quá; Ai lại bắt người khác dịch code để hiểu í bạn như thế bao giờ; Lại còn ngồi đó mà than khóc. . . )

 

[sep_hatxel]

Hãy nói bạn muốn copy dữ liệu từ trang 1 sang trang 2 với điều kiện gì;

Biết đâu làm mới sẽ hay hơn cách mà bạn đang xài cũng nên!

(Thời gian của mọi người đa số là không nhiều; mà bạn lại ít lời quá; Ai lại bắt người khác dịch code để hiểu í bạn như thế bao giờ; Lại còn ngồi đó mà than khóc. . . )

Vâng! Cảm ơn bạn rất nhiều đã quan tâm! Bạn xem giúp mình với nhé! Mình muốn copy dữ liệu từ trang 1 sang trang 2 với điều kiện là cứ 2 dòng bất kì ở trang 1 khi ghép với nhau thành 1 cặp phải thoả mãn trong 4 ô cùng màu (2cột liên tiếp) có ít nhất một ô chứa số liệu được nhập vào! Bạn xem ví dụ minh hoạ ở trang 2 bản copy nhé (cặp 0-2 là thoả mãn). Mình có bản gốc nhưng chỉ làm được với số liệu ít quá! Mình nhờ bạn xem giúp và làm trên bản copy để số liệu nhập nhiều hơn từ B1:VI11343 (Cột A là cột số thứ tự của các dòng cho mình dễ theo dõi đó là dòng nào được ghép với nhau)! Thân!

 

[SA_DQ]

Bạn xài macro sau xem sao nha

Mình muốn copy dữ liệu từ trang 1 sang trang 2 với điều kiện là cứ 2 dòng bất kì ở trang 1 khi ghép với nhau thành 1 cặp phải thoả mãn trong 4 ô cùng màu (2cột liên tiếp) có ít nhất một ô chứa số liệu được nhập vào! Bạn xem ví dụ minh hoạ ở trang 2 bản copy nhé (cặp 0-2 là thoả mãn). Mình có bản gốc nhưng chỉ làm được với số liệu ít quá!. . . Thân!

Option Explicit
Sub Xet2Dong()
 Dim jJ As Long, Ww As Long, eRw As Long, Col As Byte, Zz As Integer
 Dim Rg1 As Range, Rg2 As Range, WF As Object, Rng As Range
 Dim Timer_ As Double
  
 Sheet1.Select:               Set WF = Application.WorksheetFunction
 eRw = Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByRows, _
   SearchDirection:=xlPrevious).Row
 ReDim Khong(1 To eRw) As Boolean:                 Timer_ = Timer()
 Sheet2.[A4].Resize(eRw, 256).Clear:   Application.ScreenUpdating = False
 For jJ = 1 To eRw - 1
   For Ww = jJ + 1 To eRw
      If Khong(jJ) = False And Khong(Ww) = False Then
         For Zz = 2 To 254 Step 2
            Set Rg1 = Cells(jJ, Zz).Resize(, 2)
            Set Rg2 = Cells(Ww, Zz).Resize(, 2)
            If WF.Sum(Union(Rg1, Rg2)) < 1 Then
9 '               Union(Rg1, Rg2).Interior.ColorIndex = 34 + Zz Mod 7'
               Khong(Ww) = True:                   Exit For
            End If
            If Zz > 253 Then
               With Sheet2.[a65500].End(xlUp).Offset(2)
                  Rg1.EntireRow.Copy Destination:=.Cells(1, 1)
                  Rg2.EntireRow.Copy Destination:=.Cells(2, 1)
               End With
            End If
         Next Zz
      End If
   Next Ww
 Next jJ:                                          Sheet2.Select
 MsgBox Timer - Timer_, , "GPE Xin Báo:"
End Sub

 

[sep_hatxel]

Option Explicit
Sub Xet2Dong()
Dim jJ As Long, Ww As Long, eRw As Long, Col As Byte, Zz As Integer
Dim Rg1 As Range, Rg2 As Range, WF As Object, Rng As Range
Dim Timer_ As Double
 
Sheet1.Select: Set WF = Application.WorksheetFunction
eRw = Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious).Row
ReDim Khong(1 To eRw) As Boolean: Timer_ = Timer()
Sheet2.[A4].Resize(eRw, 256).Clear: Application.ScreenUpdating = False
For jJ = 1 To eRw - 1
For Ww = jJ + 1 To eRw
If Khong(jJ) = False And Khong(Ww) = False Then
For Zz = 2 To 254 Step 2
Set Rg1 = Cells(jJ, Zz).Resize(, 2)
Set Rg2 = Cells(Ww, Zz).Resize(, 2)
If WF.Sum(Union(Rg1, Rg2)) < 1 Then
9 ' Union(Rg1, Rg2).Interior.ColorIndex = 34 + Zz Mod 7'
Khong(Ww) = True: Exit For
End If
If Zz > 253 Then
With Sheet2.[a65500].End(xlUp).Offset(2)
Rg1.EntireRow.Copy Destination:=.Cells(1, 1)
Rg2.EntireRow.Copy Destination:=.Cells(2, 1)
End With
End If
Next Zz
End If
Next Ww
Next jJ: Sheet2.Select
MsgBox Timer - Timer_, , "GPE Xin Báo:"
End Sub

Tuyệt vời! Cách làm của bạn rất hay! Mình chân thành cảm ơn bạn! Mong bạn và mọi người chia sẻ và giúp đỡ những người khác khi gặp khó khăn như mình! Một lần nữa xin cảm ơn!

 

[sep_hatxel]

Option Explicit
Sub Xet2Dong()
Dim jJ As Long, Ww As Long, eRw As Long, Col As Byte, Zz As Integer
Dim Rg1 As Range, Rg2 As Range, WF As Object, Rng As Range
Dim Timer_ As Double

Sheet1.Select: Set WF = Application.WorksheetFunction
eRw = Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious).Row
ReDim Khong(1 To eRw) As Boolean: Timer_ = Timer()
Sheet2.[A4].Resize(eRw, 256).Clear: Application.ScreenUpdating = False
For jJ = 1 To eRw - 1
For Ww = jJ + 1 To eRw
If Khong(jJ) = False And Khong(Ww) = False Then
For Zz = 2 To 254 Step 2
Set Rg1 = Cells(jJ, Zz).Resize(, 2)
Set Rg2 = Cells(Ww, Zz).Resize(, 2)
If WF.Sum(Union(Rg1, Rg2)) < 1 Then
9 ' Union(Rg1, Rg2).Interior.ColorIndex = 34 + Zz Mod 7'
Khong(Ww) = True: Exit For
End If
If Zz > 253 Then
With Sheet2.[a65500].End(xlUp).Offset(2)
Rg1.EntireRow.Copy Destination:=.Cells(1, 1)
Rg2.EntireRow.Copy Destination:=.Cells(2, 1)
End With
End If
Next Zz
End If
Next Ww
Next jJ: Sheet2.Select
MsgBox Timer - Timer_, , "GPE Xin Báo:"
End Sub

Bạn àh! Hôm nay mình đã thử kiểm tra lại một lần nữa thì thấy rằng kết quả xuất sang sheet2 không đủ ! Khi mình nhập thêm dữ liệu kiểm tra xem thử các dòng khác thì chỉ cho vài kết quả bạn àh! Hì, mong bạn bớt chút thêm thời gian hoàn thiện thêm sao cho có bao nhiêu kết quả đều xổ ra hết! Cảm ơn bạn!

 

[SA_DQ]

Đúng là còn bỏ sót;

Bạn thử chạy macro này trong nữa giờ xem sao, trong khi chờ f ương án khác cải thiện tốc độ hơn:

Option Explicit
Sub Xet2Dong()
 Dim jJ As Long, Ww As Long, eRw As Long, Col As Byte, Zz As Integer
 Dim Rg1 As Range, Rg2 As Range, WF As Object, Rng As Range
 Dim Timer_ As Double
  
 Sheet1.Select:               Set WF = Application.WorksheetFunction
 eRw = Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByRows, _
   SearchDirection:=xlPrevious).Row
 ReDim Khong(1 To eRw) As Boolean:                 Timer_ = Timer()
 Sheet2.[A4].Resize(eRw, 256).Clear:   Application.ScreenUpdating = False
 For jJ = 1 To eRw - 1
   For Ww = jJ + 1 To eRw
'      If Khong(jJ) = False And Khong(Ww) = False Then'
         For Zz = 2 To 254 Step 2
            Set Rg1 = Cells(jJ, Zz).Resize(, 2)
            Set Rg2 = Cells(Ww, Zz).Resize(, 2)
            If WF.Sum(Union(Rg1, Rg2)) < 1 Then
9 '               Union(Rg1, Rg2).Interior.ColorIndex = 34 + Zz Mod 7'
'               Khong(Ww) = True:'
               Exit For
'            ElseIf WF.Sum(Rg2) < 1 Then'
'               Khong(Ww) = True  '
            End If
            If Zz > 253 Then
               With Sheet2.[a65500].End(xlUp).Offset(2)
                  Rg1.EntireRow.Copy Destination:=.Cells(1, 1)
                  Rg2.EntireRow.Copy Destination:=.Cells(2, 1)
               End With
            End If
         Next Zz
'      End If'
   Next Ww
 Next jJ:                                          Sheet2.Select
 MsgBox Timer - Timer_, , "GPE Xin Báo:"
End Sub

Khi nào hết kiên nhẫn với macro, hãy nhấn {CTRL}+{Pause Break} & thoát luôn khi được hỏi;

Cũng sẽ có những kết quả nào đó . . .

 

[SA_DQ]

Bạn xài cái ni, sẽ tiết kiệm hơn 1/10 thời gian đó nghe!

Option Explicit
Sub CountValueToColumnA()
 Dim WF, Rng As Range, Cls As Range, cRg As Range, Rg1 As Range, Rg2 As Range
 Dim eRw As Long, jJ As Long, Ww As Long, zZ As Integer
 Const GN As String = "-"
 Dim Timer_ As Double

 Timer_ = Timer:                       Sheet1.Select
 eRw = Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByRows, _
   SearchDirection:=xlPrevious).Row: Sheet2.Rows("2:2").ClearContents
 Sheet2.[A4].Resize(eRw, 256).Clear:   Application.ScreenUpdating = False
 Set Rng = [B1].Resize(eRw):           Set WF = Application.WorksheetFunction
 Rng.Interior.ColorIndex = 0
 For Each Cls In Rng
   If WF.Count(Cls.Resize(, 255)) = 0 Then _
      Cls.Offset(, -1).Interior.ColorIndex = 38
 Next Cls                              '0.484'
 For jJ = 1 To eRw - 1
   If Cells(jJ, "A").Interior.ColorIndex < 9 Then
      For Ww = jJ + 1 To eRw
         If Cells(Ww, "A").Interior.ColorIndex < 9 Then
            For zZ = 2 To 254 Step 2
               Set Rg1 = Cells(jJ, zZ).Resize(, 2)
               Set Rg2 = Cells(Ww, zZ).Resize(, 2)
               If WF.Sum(Union(Rg1, Rg2)) < 1 Then Exit For
               If zZ > 253 Then
                  With Sheet2.[a65500].End(xlUp).Offset(2)
                     Rg1.EntireRow.Copy Destination:=.Cells(1, 1)
                     Rg2.EntireRow.Copy Destination:=.Cells(2, 1)
                  End With
                  [iv2].End(xlToLeft).Offset(, 1).Value = Timer - Timer_
               End If
            Next zZ
         End If
      Next Ww
   End If
 Next jJ
 MsgBox Timer() - Timer_
End Sub

 

[sep_hatxel]

Option Explicit
Sub CountValueToColumnA()
Dim WF, Rng As Range, Cls As Range, cRg As Range, Rg1 As Range, Rg2 As Range
Dim eRw As Long, jJ As Long, Ww As Long, zZ As Integer
Const GN As String = "-"
Dim Timer_ As Double
 
Timer_ = Timer: Sheet1.Select
eRw = Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious).Row: Sheet2.Rows("2:2").ClearContents
Sheet2.[A4].Resize(eRw, 256).Clear: Application.ScreenUpdating = False
Set Rng = [B1].Resize(eRw): Set WF = Application.WorksheetFunction
Rng.Interior.ColorIndex = 0
For Each Cls In Rng
If WF.Count(Cls.Resize(, 255)) = 0 Then _
Cls.Offset(, -1).Interior.ColorIndex = 38
Next Cls '0.484'
For jJ = 1 To eRw - 1
If Cells(jJ, "A").Interior.ColorIndex < 9 Then
For Ww = jJ + 1 To eRw
If Cells(Ww, "A").Interior.ColorIndex < 9 Then
For zZ = 2 To 254 Step 2
Set Rg1 = Cells(jJ, zZ).Resize(, 2)
Set Rg2 = Cells(Ww, zZ).Resize(, 2)
If WF.Sum(Union(Rg1, Rg2)) < 1 Then Exit For
If zZ > 253 Then
With Sheet2.[a65500].End(xlUp).Offset(2)
Rg1.EntireRow.Copy Destination:=.Cells(1, 1)
Rg2.EntireRow.Copy Destination:=.Cells(2, 1)
End With
[iv2].End(xlToLeft).Offset(, 1).Value = Timer - Timer_
End If
Next zZ
End If
Next Ww
End If
Next jJ
MsgBox Timer() - Timer_
End Sub

Hì! Hôm nay mình đã nhập xong dữ liệu và cho chạy theo cả 2 cách! Đều cho ra kết quả, nhưng đúng là phải có sự kiên nhẫn chờ đợi thật! Hì, mất gần 3 giờ đồng hồ!

 

[ChanhTQ@]

Nếu đây vẫn là công việc thường xuyên của bạn, ta tiếp tục cải tiến macro

Bạn có nhu cầu không vậy?

Chúc thành công trong ngày!

 

[sep_hatxel]

Bạn có nhu cầu không vậy?

Chúc thành công trong ngày!

Hì! Vâng! Mình rất cảm ơn bạn! Nếu bạn cải tiến được tốc độ của maco thì hay quá!

 

[NH_DK]

Em xin hỏi cách dùng cấu trúc này:

If Not .... Is Nothing Then
.....

Thực ra, em cũng sử dụng rồi những chưa hiểu kỹ lắm. A/C vui lòng chỉ dùm em nha!!

 

[ChanhTQ@]

Em xin hỏi cách dùng cấu trúc này:

If Not .... Is Nothing Then
.....

Thực ra, em cũng sử dụng rồi những chưa hiểu kỹ lắm. A/C vui lòng chỉ dùm em nha!!

Nếu sau từ khóa 'Not' là chữ "Intersect" thì đến chữ ký của Sa_DQ & nhấn vô từ đó để tham khảo.

Nhưng lần sau chớ chen ngang vậy nha; Hãy lập topic mới cho mình

 

[NH_DK]

Nếu sau từ khóa 'Not' là chữ "Intersect" thì đến chữ ký của Sa_DQ & nhấn vô từ đó để tham khảo

Nhưng nếu em muốn sau 'Not' là một biến. Anh có cthể cho em 1 hoặc 2 ví dụ dễ hiểu!!?

 

[ptm0412]

Nhưng nếu em muốn sau 'Not' là một biến. Anh có cthể cho em 1 hoặc 2 ví dụ dễ hiểu!!?

Not đơn giản là 1 phủ định, dùng cho 1 biến hoặc 1 expression, hoặc 1 kết quả của 1 hàm nào đó, với điều kiện biến, expression, hàm, ... phải có giá trị Logic (True, False)

Thí dụ:

1. Biến:

Dim Test As Boolean
Test = True
Msgbox Not Test

2. Expression:

Dim MyNum As Long
MyNum = [A1]
MsgBox Not (MyNum >10 And MyNum <100)

3. Kết quả của 1 hàm:

MsgBox Not IsNumeric(15)

 

[ndu96081631]

Nhưng nếu em muốn sau 'Not' là một biến. Anh có cthể cho em 1 hoặc 2 ví dụ dễ hiểu!!?

Ví dụ thế này

Sub Test
  Dim fRng as Range
  Set fRng = Range("gì gì đó").Find(.......)
  If Not fRng is Nothing then
     'Code
  End If
End Sub

Trong trường hợp này thì If Not fRng is Nothing là ý muốn nói: NẾU fRng CÓ TỒN TẠI THÌ (lở fRng không tồn tại thì code ở dưới liên quan đến fRng sẽ bị lỗi)
fRng is Nothing nghĩa là fRng.. chẳng có gì (không tồn tại)
Not fRng is Nothing: nghĩa là ngược với phát biểu trên, nghĩa là CÓ TỒN TẠI

 

[liro]

Đây là đoạn code em làm để ẩn hàng trong bảng excel nhưng tốc độ hơi chậm mong mọi người giúp cải tiến đoạn code này giùm em.

Private Sub Worksheet_Change(ByVal Target As Range)
Dim Arr(10) As Variant
Arr(1) = 43
Arr(2) = 44
Arr(3) = 45
Arr(4) = 46
Arr(8) = 47
Arr(5) = 50
Arr(6) = 15
Arr(7) = 16
Arr(8) = 51
Arr(9) = 52
Arr(10) = 17
Dim Ii As Variant
On Error Resume Next
Application.ScreenUpdating = False
For Each Ii In Arr
         If Not Intersect([K1], Target) Is Nothing Then
               If Range("b" & Ii).Value = 0 Then
                   Rows(Ii).EntireRow.Hidden = True
               Else
                   Rows(Ii).EntireRow.Hidden = False
               End If
         End If
 Next Ii
Application.ScreenUpdating = True
End Sub

 

[ndu96081631]

Đây là đoạn code em làm để ẩn hàng trong bảng excel nhưng tốc độ hơi chậm mong mọi người giúp cải tiến đoạn code này giùm em.

Private Sub Worksheet_Change(ByVal Target As Range)
Dim Arr(10) As Variant
Arr(1) = 43
Arr(2) = 44
Arr(3) = 45
Arr(4) = 46
Arr(8) = 47
Arr(5) = 50
Arr(6) = 15
Arr(7) = 16
Arr(8) = 51
Arr(9) = 52
Arr(10) = 17
Dim Ii As Variant
On Error Resume Next
Application.ScreenUpdating = False
For Each Ii In Arr
         If Not Intersect([K1], Target) Is Nothing Then
               If Range("b" & Ii).Value = 0 Then
                   Rows(Ii).EntireRow.Hidden = True
               Else
                   Rows(Ii).EntireRow.Hidden = False
               End If
         End If
 Next Ii
Application.ScreenUpdating = True
End Sub

Liên quan đến vụ NHANH CHẬM phải xem file mới biết bạn à... Vì có thể nó bị ảnh hưởng do những thứ khác (công thức chẳng hạn)

 

[liro]

Đây là file đính kèm của em.Nhờ mọi người xem giúp.Và cho em hỏi trong excel 2007 có thể tạo nút menu mới để gán marco như trong 2003 được không. Nếu được nhờ mọi người hướng dẫn giùm em.

 

[ndu96081631]

Đây là file đính kèm của em.Nhờ mọi người xem giúp.Và cho em hỏi trong excel 2007 có thể tạo nút menu mới để gán marco như trong 2003 được không. Nếu được nhờ mọi người hướng dẫn giùm em.

Tôi đang nghĩ tại sao bạn không dùng AutoFilter nhỉ (cần gì vòng lập)

Private Sub Worksheet_Change(ByVal Target As Range)
  If Target.Address = "$K$1" Then
    Range("B13:B1000").AutoFilter 1, "<>0", , , 0
  End If
End Sub

Nhìn code của bạn và đoán thế ---> Bạn chạy thử xem thế nào nhé!
Nói thêm rằng code mà bạn đưa ở trên, khi chạy trên máy tôi chẳng thấy chậm gì cả (chẳng qua là tôi rút gọn nó thôi)

 

[liro]

Phần Filter em chưa biết. Anh đã giúp giúp cho trót giúp em đoạn code bỏ chế độ lọc filter ở đầu code với.

 

[ndu96081631]

Phần Filter em chưa biết. Anh đã giúp giúp cho trót giúp em đoạn code bỏ chế độ lọc filter ở đầu code với.

Bỏ chế độ Filter dễ mà
Ví dụ code tại sheet1:

Sheet1.AutoFilterMode = False

 

[vpcuong]

Bạn đã fix dịa chỉ của từng sheet rồi mà, với câu lệnh của bạn thì nguồn là TaoPW đích đến là Dangky, như vậy bạn muốn đi theo chiều ngược lại thì phải sủa lại nuồn và đích đến theo chiều ngược lại, chúng ta có thể làm 2 đoạn khác nhau

Sub CopyError()
Sheets("TaoPw").Range([A2], [B65536].End(xlUp)).Copy
Sheets("DangKy").[A2].PasteSpecial Paste:=xlPasteValues
MsgBox "Copy thanh cong"
End Sub

Sub CopyError1()
Sheets("DangKy").Range([A2], [B65536].End(xlUp)).Copy
Sheets("TaoPw").[A2].PasteSpecial Paste:=xlPasteValues
MsgBox "Copy thanh cong"
End Sub

 

[thangbdqtri]

Xin được chỉ giáo code access

Em mới được người bạn cho 1 phần mềm viết bằng Access. Bây giời em muốn sửa lại code một ít để theo ý của mình (VD: Hình nền; form Tác giả; thông tin trên các form khác..) thì phải làm sao? Em đã dùng nhấn phím Shift+Open để chỉnh sửa nhưng khi sửa xong không biết cách để lưu lại ở đâu. Mong các anh chỉ giáo giùm. Thank các anh nhiều!

 

[thanhtam348]

Anh ndu!
Nhờ anh xem lại dùm em file nầy, nó đang bị lổi ở phần date.

 

[TrungChinhs]

Tôi muốn gộp 2 vòng lặp này thành 1 để quét từ cột 3 đến 6 rồi lại quét tiếp từ cột 9 đến 14 thì viết như thế nào ?

Sub Sum()
    For j = 3 To 6
        Cells(5, j) = Application.Sum(Cells(6, j).Resize(20))
    Next
    For j = 9 To 14
        Cells(5, j) = Application.Sum(Cells(6, j).Resize(20))
    Next

End Sub

Nhờ các bạn chỉ giúp. Thanks !

 

[ptm0412]

Anh thử cái này xem:

Sub Sum()
    For j = 3 To 14
        If j = 7 Then j = 9
        Cells(5, j) = Application.Sum(Cells(6, j).Resize(20))
    Next
End Sub

 

[TrungChinhs]

Anh thử cái này xem:

Sub Sum()
    For j = 3 To 14
        If j = 7 Then j = 9
        Cells(5, j) = Application.Sum(Cells(6, j).Resize(20))
    Next
End Sub

Học được chiêu: cứ cho biến chạy từ cột đầu đến cột cuối cùng, khi quét đến cột cuối của vùng này thì nhẩy ngay sang cột đầu của vùng kế tiếp: If j = 7 Then j = 9
Thật là tuyệt vời. Cảm ơn ptm0412 !

 

[ptm0412]

Biết thêm 1 chiêu, không bổ bề ngang cũng bổ bề dọc nhỉ anh nhỉ. Biếu thêm 1 chiêu không dùng vòng lặp:

Sub sum()
    Set rng = Union(Range("C5:F5"), Range("I5:N5"))
    rng.FormulaR1C1 = "=sum(R[1]C:R[20]C)"
    rng.Value = rng.Value
End Sub

 

[kan]

Nhờ giải thích cách xử lý code về sử lý chuỗi !
Thông báo lỗi ở hàm char(10)

Sub Data_Reading()
Dim MyRequest As String, title As String
Dim lengh As Integer
Repeat:
MyRequest = InputBox(" Cho sè th¸ng tÝnh to¸n", "Tính toán thu?", "1-12")
title = "Error: Vµo sai sè th¸ng tÝnh to¸n" & Chr(10) & Chr(10) & "VÝ dô : Muèn tÝnh tõ th¸ng 1 ®Õn th¸ng 5 cÇn khai b¸o : 1-5"
lengh = Len(MyRequest)

Select Case lengh
Case 0
Exit Sub
Case 1
MsgBox (title)
GoTo Repeat
Case 2
MsgBox (title)
GoTo Repeat
Case 3
StartMonth = Left(MyRequest, 1)
EndMonth = Right(MyRequest, 1)
Case 4
StartMonth = Left(MyRequest, 1)
EndMonth = Right(MyRequest, 2)
Case 5
StartMonth = Left(MyRequest, 2)
EndMonth = Right(MyRequest, 2)
End Select
If StartMonth > EndMonth Or StartMonth > 12 Then
MsgBox (title)
GoTo Repeat
End If
NumberOfMonth = EndMonth - StartMonth + 1
End Sub

 

[ndu96081631]

Nhờ giải thích cách xử lý code về sử lý chuỗi !
Thông báo lỗi ở hàm char(10)

Đưa file cụ thể lên luôn đi... chứ code này tôi chạy chẳng thấy lỗi nào cả (ngoại trừ lỗi chưa khai báo biến đầy đủ)

 

[thanhtratt]

Sửa dùm code

Anh chị xem file giúp mình nhé.
Mình đã làm thử nhiều cách nhưng k được đành phải làm phiền các Anh Chị vậy!
Mình muốn khi bấm vào cột Tên thuốc vào chọn tên thuốc bấm Enter combo tự đông cập nhật Tên thuốc , ĐVT, Đơn giá xong thì con trỏ tự động nhảy đến cột Số lượng để mình nhập số lương xong mình bấm Enter sẽ nhảy xuông dòng kế tiếp của cột Tên thuốc để mình tiếp tục nhập tiếp.
Xin các Anh Chị chỉ giáo em thành thật cám ơn

 

[TrungChinhs]

Nhờ sửa giúp Code trong Sub Sum !

Chào các bạn ! trong file ví dụ đính kèm Tôi viêt code để thực hiện các lệnh Sum như sau:

Sub Sum_All(Cls As Range)
'Dim j As Long
With Application
    .ScreenUpdating = 0
    .Calculation = 2
    On Error Resume Next
    With ActiveSheet
        Rz = Cls(65000, 3).End(3).Row
 [COLOR=red]       j = Cls(1, 5).Column - Cls.Column[/COLOR]
'Cong Diem
        With [Cls].Offset(1).Resize(Rz).SpecialCells(4).Offset(, 1).SpecialCells(4)
            For j = j To j + 2
            For i = 1 To .Areas.Count
                  .Areas(i)(0, 3) = Application.CountA(.Areas(i).Offset(, 2))
                  .Areas(i)(0, j) = Application.Sum(.Areas(i).Offset(, j - 1))
            Next
            Next
        End With
'Cong khu
        With [Cls].Resize(Rz).SpecialCells(4)
[COLOR=red]'        j = Cls(1, 5).Column - Cls.Column[/COLOR]
            For j = j To j + 3
           For i = 1 To .Areas.Count
                .Areas(i)(0, j) = Application.Sum(.Areas(i).Offset(, 1).SpecialCells(2).Offset(, j - 2))
            Next
            Next
        End With
'Cong huyen
[COLOR=red]'       j = Cls(1, 5).Column - Cls.Column[/COLOR]
       For j = j To j + 5
            Cls(0, j) = Application.Sum(Cls.Resize(Rz).SpecialCells(2).Offset(, j - 1))
        Next
    End With
End With
End Sub

Sub R_Sum()
    Sum_All [d9]
End Sub

Để kết quả đúng thì trước mỗi For tôi phải đặt lại câu lệnh j = Cls(1, 5).Column - Cls.Column
Vậy phải viết như thế nào thì tránh được việc nhắc lại câu lệnh trên trước mỗi vòng lặp. Tôi đã thử viết truyền tham số cho J nhưng không được (tôi đang học viết kiểu Sub có tham số truyền nên chưa biết nhiều).
Nhờ các bạn nghiên cứu sửa giúp. Thanhks !

 

[ndu96081631]

Chào các bạn ! trong file ví dụ đính kèm Tôi viêt code để thực hiện các lệnh Sum như sau:

Sub Sum_All(Cls As Range)
  .....
  .....
End Sub

Sub R_Sum()
    Sum_All [d9]
End Sub

Để kết quả đúng thì trước mỗi For tôi phải đặt lại câu lệnh j = Cls(1, 5).Column - Cls.Column
Vậy phải viết như thế nào thì tránh được việc nhắc lại câu lệnh trên trước mỗi vòng lặp. Tôi đã thử viết truyền tham số cho J nhưng không được (tôi đang học viết kiểu Sub có tham số truyền nên chưa biết nhiều).
Nhờ các bạn nghiên cứu sửa giúp. Thanhks !

Anh ơi, có thể mô tả cho mọi người ý anh muốn SUM như thế nào không? Đọc code vả quá

 

[Lê Duy Thương]

Chào các bạn ! trong file ví dụ đính kèm Tôi viêt code để thực hiện các lệnh Sum như sau:

Sub Sum_All(Cls As Range)
'Dim j As Long
With Application
    .ScreenUpdating = 0
    .Calculation = 2
    On Error Resume Next
    With ActiveSheet
        Rz = Cls(65000, 3).End(3).Row
 [COLOR=red]       j = Cls(1, 5).Column - Cls.Column[/COLOR]
'Cong Diem
        With [Cls].Offset(1).Resize(Rz).SpecialCells(4).Offset(, 1).SpecialCells(4)
            For j = j To j + 2
            For i = 1 To .Areas.Count
                  .Areas(i)(0, 3) = Application.CountA(.Areas(i).Offset(, 2))
                  .Areas(i)(0, j) = Application.Sum(.Areas(i).Offset(, j - 1))
            Next
            Next
        End With
'Cong khu
        With [Cls].Resize(Rz).SpecialCells(4)
[COLOR=red]'        j = Cls(1, 5).Column - Cls.Column[/COLOR]
            For j = j To j + 3
           For i = 1 To .Areas.Count
                .Areas(i)(0, j) = Application.Sum(.Areas(i).Offset(, 1).SpecialCells(2).Offset(, j - 2))
            Next
            Next
        End With
'Cong huyen
[COLOR=red]'       j = Cls(1, 5).Column - Cls.Column[/COLOR]
       For j = j To j + 5
            Cls(0, j) = Application.Sum(Cls.Resize(Rz).SpecialCells(2).Offset(, j - 1))
        Next
    End With
End With
End Sub

Sub R_Sum()
    Sum_All [d9]
End Sub

Để kết quả đúng thì trước mỗi For tôi phải đặt lại câu lệnh j = Cls(1, 5).Column - Cls.Column
Vậy phải viết như thế nào thì tránh được việc nhắc lại câu lệnh trên trước mỗi vòng lặp. Tôi đã thử viết truyền tham số cho J nhưng không được (tôi đang học viết kiểu Sub có tham số truyền nên chưa biết nhiều).
Nhờ các bạn nghiên cứu sửa giúp. Thanhks !

ANH THỬ CÁI NÀY TRƯỚC XEM SAO
On Error Resume Next
Set j = Cls(1, 5).Column - Cls.Column

 

[ndu96081631]

ANH THỬ CÁI NÀY TRƯỚC XEM SAO
On Error Resume Next
Set j = Cls(1, 5).Column - Cls.Column

Cls(1, 5).Column - Cls.Column sẽ ra 1 số nguyên dương ===> j phải là biến Long, vậy sao lại dùng Set?
Set chỉ dùng đối với biến Object thôi Thương à!

 

[TrungChinhs]

Anh ơi, có thể mô tả cho mọi người ý anh muốn SUM như thế nào không? Đọc code vả quá

Xin lỗi các bạn vì đã không mô tả kỹ. Code tôi viết có ý như sau:
1- Cộng tất cả các dòng trong 1 Điểm TĐC lên dòng Điểm TĐC. Ví dụ: I10 = Sum(I11:I12).
2- Cộng tất cả các điểm TĐC trong 1 khu TĐC lên dòng Khu TĐC. Ví dụ: I9 = Sum(I10, I13, I15,.....I30).
3- Cộng tất cả các Khu TĐC lên dòng toàn huyện. Ví dụ: I8 = Sum(I9, I29, I32,.....I66).

Để tiện sử dụng phương thức Specialcells tôi đã bố trí dữ liệu theo từng mảng: mảng Khu TĐC để riêng tại cột D, mảng Điểm TDC để riêng tại cột E, dữ liệu của mảng Điểm TĐC để riêng tại cột F.

Để xác định vùng chứa dữ liệu của Điểm TĐC và Khu TĐC tôi dùng phương thức Specialcells(...) để xác định mảng cần phải cộng - thay cho sử dụng SumIf.

Để xác định các dòng, cột để cộng tôi chọn 1 Range để truyền tham số Cls. Ví dụ [d9]

Tôi sử dụng biến i để quét dòng và biến j để quét cột.
Ví dụ khi cộng theo điểm thì biến J chạy từ cột 4 đến cột cuối
- Khi không dùng tham số truyền tôi phải viết i = 4 to ...
- Khi dùng tham số truyền tôi j = Cls(1, 5).Column - Cls.Column để xác định cột đầu tiên là cột 4

Vấn đề là tại mỗi một kiểu cộng (điểm, khu, huyện) tôi phải viết lại câu lệnh j = Cls(1, 5).Column - Cls.Column để xác định cột đầu tiên.

Tôi không hiểu nhiều về biến nhưng cứ thử bừa vụ Set j = Cls(1, 5).Column - Cls.Column cũng đã thử và kết quả là linh tinh beng chẳng biết đường nào mà lần.

Trong file đính kèm chỉ cần mở lại các dòng lệnh j = Cls(1, 5).Column - Cls.Column ở đầu mỗi vòng lặp là kết quả đúng ngay.

Rất mong các bạn nghiên cứu và trợ giúp.

Lưu ý: Tôi muốn được các bạn giúp theo hướng của tôi đang làm dù là chưa tối ưu vì vấn đề ở đây là ví dụ để học. Nếu chuyển sang hướng khác tôi sợ không tiếp thu được.

 

[SA_DQ]

Cái macro R_Sum() chả để làm chi cả đó & tham khảo cái ní xem sao

Sub Sum_All()
 Dim Cls As Range:             Dim jJ As Long
 
 Set Cls = [D9]
 With Application
    .ScreenUpdating = 0
    .Calculation = 2
 End With                      '<=|'
 On Error Resume Next
    With ActiveSheet
        Rz = Cls(65000, 3).End(3).Row
        jJ = Cls(1, 5).Column - Cls.Column
'Cong Diem:'
        With [Cls].Offset(1).Resize(Rz).SpecialCells(4).Offset(, 1).SpecialCells(4)
            For j = jJ To jJ + 2
            For i = 1 To .Areas.Count
                  .Areas(i)(0, 3) = Application.CountA(.Areas(i).Offset(, 2))
                  .Areas(i)(0, j) = Application.Sum(.Areas(i).Offset(, j - 1))
            Next
            Next
        End With
'Cong Khu:'
        With [Cls].Resize(Rz).SpecialCells(4)
        jJ = Cls(1, 5).Column - Cls.Column
            For j = jJ To jJ + 3
            For i = 1 To .Areas.Count
                .Areas(i)(0, j) = Application.Sum(.Areas(i).Offset(, 1).SpecialCells(2).Offset(, j - 2))
            Next
            Next
        End With
'Cong Huyen:'
       jJ = Cls(1, 5).Column - Cls.Column
       For j = jJ To jJ + 5
            Cls(0, j) = Application.Sum(Cls.Resize(Rz).SpecialCells(2).Offset(, j - 1))
        Next
    End With

With Application
    .ScreenUpdating = 100  '?'
    .Calculation = 1  '?'
End With
End Sub

 

[TrungChinhs]

Sub Sum_All()
 Dim Cls As Range:             Dim jJ As Long
 
 Set Cls = [D9]
 With Application
    .ScreenUpdating = 0
    .Calculation = 2
 End With                      '<=|'
 On Error Resume Next
    With ActiveSheet
        Rz = Cls(65000, 3).End(3).Row
        jJ = Cls(1, 5).Column - Cls.Column
'Cong Diem:'
        With [Cls].Offset(1).Resize(Rz).SpecialCells(4).Offset(, 1).SpecialCells(4)
            For j = jJ To jJ + 2
            For i = 1 To .Areas.Count
                  .Areas(i)(0, 3) = Application.CountA(.Areas(i).Offset(, 2))
                  .Areas(i)(0, j) = Application.Sum(.Areas(i).Offset(, j - 1))
            Next
            Next
        End With
'Cong Khu:'
        With [Cls].Resize(Rz).SpecialCells(4)
        jJ = Cls(1, 5).Column - Cls.Column
            For j = jJ To jJ + 3
            For i = 1 To .Areas.Count
                .Areas(i)(0, j) = Application.Sum(.Areas(i).Offset(, 1).SpecialCells(2).Offset(, j - 2))
            Next
            Next
        End With
'Cong Huyen:'
       jJ = Cls(1, 5).Column - Cls.Column
       For j = jJ To jJ + 5
            Cls(0, j) = Application.Sum(Cls.Resize(Rz).SpecialCells(2).Offset(, j - 1))
        Next
    End With

With Application
    .ScreenUpdating = 100  '?'
    .Calculation = 1  '?'
End With
End Sub

Em cảm ơn Thầy ! em đã test thử Code cho kết quả đúng rồi và câu lệnh Set Cls=... đã thay thế cho Sub R-Sum.
Em viết thêm sub này là vì em đang tập viết sub có tham số truyền.

Và có một số điều em chưa hiểu:
1- Tại sao nhiều khi không cần khai báo biến: Dim... mà code vẫn hoạt động bình thường - ngay trong code này bỏ Dim... code vẫn chạy đúng. Chính vì lý do này nên khi viết code em thường bỏ Dim ... ?

2- Trường hợp nào thì sử dụng Set... ? em gặp nhiều trường hợp nếu Set ... thì code chạy đúng nhưng cũng có nhiều trường hợp dùng Set... thì code bị lỗi hoặc cho kết quả sai ?

 

[ChanhTQ@]

(0) Em viết thêm sub này là vì em đang tập viết sub có tham số truyền.

Và có một số điều em chưa hiểu:
(1)- Tại sao nhiều khi không cần khai báo biến: Dim... mà code vẫn hoạt động bình thường - ngay trong code này bỏ Dim... code vẫn chạy đúng. Chính vì lý do này nên khi viết code em thường bỏ Dim ... ?

(2) - Trường hợp nào thì sử dụng Set... ? em gặp nhiều trường hợp nếu Set ... thì code chạy đúng nhưng cũng có nhiều trường hợp dùng Set... thì code bị lỗi hoặc cho kết quả sai ?

(0) Macro gọi 1 macro khác

  Sub GPE_ ()
    Dim jJ As Byte, Zz As Byte
 
    For jJ = 1 To 10 Step 3
        GPE_COM jJ 
        
    Next jJ
  End Sub

 Sub GPE_COM(Zz As Byte)
   Const StrC As String = "@0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" 
   Dim Jj As Integer

   For Jj = 1 To Zz
       MsgBox Mid(StrC,Jj,1),,Zz
  Next Jj
 End Sub

(1) Bỏ cũng chạy, nhưng fải là:
(*) Nhà lập trình luôn nắm vững các biến của mình;
(*) Macro cỏn con, không tốn nhiêu bộ nhớ;
(*) Không cần đến sự hỗ trợ về chính tả của trình biên dịch luôn theo dõi bạn trong suốt quá trình việt code;
. . .

(2) NDU đã nói, nhưng chưa hết í để bạn hiểu:

Các biến đối tượng như

Dim Rng As Range, Sh As WorkSheet,. . .

Cần dùng Set

Còn những cái nhỏ lẻ khác như Long, Integer, String, Double, . . . ta có thể

StrC = "GPE": MyNum = 35 , . . . .

Tạm thế nha & fải chi bạn ở lớp VBA, nhỉ?

 

[ndu96081631]

Lưu ý: Tôi muốn được các bạn giúp theo hướng của tôi đang làm dù là chưa tối ưu vì vấn đề ở đây là ví dụ để học. Nếu chuyển sang hướng khác tôi sợ không tiếp thu được.

Hướng mà anh nói em e rằng không khả thi, ít nhất là đối với bài này!
Em dùng công thức bình thường rất dễ dàng (nếu anh thích có thể tự chuyển thành code)
Em làm như sau:
- AutoFilter cột E với điều kiện NonBlanks
- Quét chọn từ I10 đến I83 rồi gõ vào thanh Formula công thức

=SUM($I11:$I$86)-2*SUMIF($E11:$E$86,"*",$I11:$I$86)

- Bấm tổ hợp phím Ctrl + Enter để kết thúc
- Show All cột E
------------
Vậy là xong!
Những phần SUM còn lại anh có thể tự mình suy nghĩ thêm
Để viết thành code, anh làm theo hướng này ---> Khỏe re, chỉ có mấy dòng code là xong!
Ẹc... Ẹc...
-----------------
Em nói thêm: Xem file của anh Trung Chinh, em thấy hình như anh bỏ mất dòng Option Explicit ở đầu code, chính điều này nên anh không cần khai báo biến nó cũng chẳng nói gì! Cái này có 2 mặt lợi hại:
- Lợi: Anh đở tốn công khai báo
- Hại: Anh bị mất các ToolTip hổ trợ về các thuộc tính của biến ---> Xem hình:



Vậy làm sao anh có thể nhớ hết tất cả các thuộc tính, nhất là những thuộc tính mà anh ít khi dùng đến... Ngoài ra nếu anh không khai báo đàng hoàng thì khi code bị lỗi anh rất khó theo dỏi
------------------------------------
Để dòng Option Explicit luôn tự chèn vào code (khỏi gõ), trong cửa sổ VBE, anh vào menu Tools\Options và làm giống như hình

 

[TrungChinhs]

Nhờ Mod, Smod xóa giúp bài này. Thanks !

 

[ndu96081631]

Nhờ các bạn giải thích giúp:
1- Số-2 trong công thức này có ý nghĩa gì ?
2- Ý nghĩa (tác dụng) của việc dùng hàm Sum(...)-2 để nhân với hàm Sumif(...)
Thanks !

Cũng chẳng biết giải thích với anh thế nào nữa... Tuy nhiên có thể gợi ý rằng: Hàm này được tính từ dưới lên, tức từ cell I83 trở lên ---> Vậy anh hãy đến cell I83 và I80 mà nghiên cứu, tự nhiên sẽ hiểu ===> Từ đó suy ngược lên trên
(lúc làm hàm này, em cũng bắt đầu từ dưới lên trên đấy)
------------------
Ngoài ra anh có thể tham khảo thêm bài này:
http://www.giaiphapexcel.com/forum/...tổng-con-cho-từng-phân-đoạn&p=87995#post87995

 

[TrungChinhs]

Cũng chẳng biết giải thích với anh thế nào nữa... Tuy nhiên có thể gợi ý rằng: Hàm này được tính từ dưới lên, tức từ cell I83 trở lên ---> Vậy anh hãy đến cell I83 và I80 mà nghiên cứu, tự nhiên sẽ hiểu ===> Từ đó suy ngược lên trên
(lúc làm hàm này, em cũng bắt đầu từ dưới lên trên đấy)
------------------
Ngoài ra anh có thể tham khảo thêm bài này:
http://www.giaiphapexcel.com/forum/...tổng-con-cho-từng-phân-đoạn&p=87995#post87995

Cảm ơn Em ! Hôm nay đánh vật với mấy đoạn code nên đầu óc mụ mẫm quá. Sau Post bài thì anh tiếp tục nghiên cứu và mới nhớ đến thứ tự ưu tiên của các phép tính (nhân chia trước, cộng trừ sau) từ đó anh đã hiểu là trừ 2 lần Sumif chứ không phải là Sum(...)-2 như anh đã hỏi. Còn tại sao phải trừ 2 lần thì anh biết rồi. Do đã hiểu và chưa thấy ai trả lời nên anh mới xóa bài, không biết là em đã xem.

Xin chân thành cảm ơn sự quan tâm giúp đỡ của các bạn !

 

[daodlpc]

Tìm MAX, MIN bằng MACRO ?

Em đang xử lý đoạn code tìm 6 giá trị MAX ở ROW thứ 34 mà chưa biết làm thế nào ca ->
Các huynh cứu em với
Em đa tạ các huynh nhiêuuuuuuuuuuuu
Private Sub Worksheet_SelectionChange(ByVal Target As Range)

'End Sub
Dim i%, n%, tam%, j%
Dim tim As Integer
For n = 3 To 1116 Step 34
If Sheet2.Cells(n, 2) <> "" Then
tam = 0
For i = 5 To 28
For j = n To n + 32
tam = tam + Sheet2.Cells(j, i)
Next j
Sheet2.Cells(n + 33, i) = tam
tam = 0
Next i
End If
Next n
End Sub

 

[daodlpc]

Tìm MAX, MIN bằng MACRO ?

Em đang xử lý đoạn code tìm 6 giá trị MAX ở ROW thứ 34 mà chưa biết làm thế nào ca ->
Các huynh cứu em với
Em đa tạ các huynh nhiêuuuuuuuuuuuu
Private Sub Worksheet_SelectionChange(ByVal Target As Range)

'End Sub
Dim i%, n%, tam%, j%
Dim tim As Integer
For n = 3 To 1116 Step 34
If Sheet2.Cells(n, 2) <> "" Then
tam = 0
For i = 5 To 28
For j = n To n + 32
tam = tam + Sheet2.Cells(j, i)
Next j
Sheet2.Cells(n + 33, i) = tam
tam = 0
Next i
End If
Next n
End Sub

 

[tuyettrang186]

Mọi người choe em hỏi? Đoạn code:

Sub Loc_Ngay()
    With S1.Range("A1:B10")
        .AdvancedFilter 2, Range("G1:H2"), Range("A5")
        '.AdvancedFilter 2, Range("G1:H2"), Range("A5:B5") 'Cai thi duoc
    End With
End Sub

Sao nó chỉ lọc ngày mà không lọc được tên hàng?

 

[SA_DQ]

Với dòng lệnh này:

 .AdvancedFilter 2, S2.Range("G1:H2"), S2.Range("A5:B5")

Nó sẽ xuất ra cho bạn 2 cột dữ liệu; Còn lệnh trên ta bảo nó xuất ra 1 cột, thì nó làm đúng rồi còn gì!

Cớ gì trách nó & theo mình, bạn nên viết tường minh hơn

 

[hoangquycong]

các huynh đệ xin cho hỏi,có cách nào để ngắt giữa đoạn một chương trình,rồi dùng form và drag chuột để nhận vùng selection mới không.Tôi lấy ví dụ trong một ứng dụng,tôi muốn ngắt chương trình và cho người sử dụng chọn một vùng và xử lí tiếp trong vùng đó.cảm ơn

 

[tuyettrang186]

Vâng. Điều này thì đúng rùi ah. Nhưng em thắc mắc tại sao trong ví dụ này em làm thế này thì lại được:

Sub Loc()
  Range("A7:C1000").Clear
  With Sheet1.Range("A1:C1000")
    .AdvancedFilter 2, Range("K1:L2"), Range("A7")
  End With
End Sub

nhờ anh xem dùm?

 

[NH_DK]

Mọi người choe em hỏi? Đoạn code:

Sub Loc_Ngay()
With S1.Range("A1:B10")
.AdvancedFilter 2, Range("G1:H2"), Range("A5")
'.AdvancedFilter 2, Range("G1:H2"), Range("A5:B5") 'Cai thi duoc
End With
End Sub

Sao nó chỉ lọc ngày mà không lọc được tên hàng?

Mình kiểm tra thấy code của bạn lọc được mà? Mình tham gia thêm chút xíu ha: Bạn nên thêm

Range("A1:B1000").Clear

Đây là code mình sửa lại của bạn chút nhé:

Sub Loc_Ngay()
    Range("A5:B1000").Clear
    With S1.Range("A1").CurrentRegion
        .AdvancedFilter 2, Range("G1:H2"), Range("A5")
    End With    
End Sub

Bạn tham khảo nhé!

 

[ChanhTQ@]

Hình như nó liên quan đến vấn đề này (trong help)

[B][I]CopyToRange[/I][/B]    Optional [B]Variant[/B]. The destination range for the copied rows if [B][I]Action[/I][/B] is [B]xlFilterCopy[/B]. Otherwise,  this argument is ignored.

Mình thử trường hợp sau:


(*) Đổi dòng lệnh đầu tiên thành:

Range("A7:C1000").Offset(1).Clear

Sau đó xóa [B7:C7] & chạy macro, sẽ ra kết quả chỉ 1 cột 'A'


Rất cảm ơn bạn!

 

[ptm0412]

các huynh đệ xin cho hỏi,có cách nào để ngắt giữa đoạn một chương trình,rồi dùng form và drag chuột để nhận vùng selection mới không.Tôi lấy ví dụ trong một ứng dụng,tôi muốn ngắt chương trình và cho người sử dụng chọn một vùng và xử lí tiếp trong vùng đó.cảm ơn

Dùng 1 câu lệnh inputbox là được.

 

[huuchuong1174]

Mình có đoạn code dùng để trích lọc dữ liệu theo tên sheet (do mình sử dụng lại của 1 bạn trên diễn đàn) để áp dụng trong file Quản ly cong van của mình. Tuy nhiên mình không hiểu ý nghĩa của từng câu lệnh nên chỉnh sửa theo một số ý kiến giúp đỡ của các bạn trên diễn đàn, nay nhờ giải thích dùm ý nghĩa của đoạn code sau:

Private Sub Workbook_SheetActivate(ByVal Sh As Object)
Dim A As String, Vung As Range, K As Integer
    Application.ScreenUpdating = False
    A = ActiveSheet.Name
    Set Vung = Sheets("CV DEN").[A5:Z5]
        If A <> "CV DEN" Then
        Sheets("CV DEN").Unprotect "bld"
        On Error Resume Next
        K = Application.WorksheetFunction.Match(A, Vung, 0)
            ActiveSheet.Cells.Clear
            With Sheets("CV DEN").Range(Sheets("CV DEN").[a5], Sheets("CV DEN").[a10000].End(xlUp)).Resize(, 26)
                ThisWorkbook.UnprotectSharing SharingPassword:="bld"
                .AutoFilter K, "x"
                .SpecialCells(12).Copy ActiveSheet.[a5]
                .AutoFilter
            End With
        End If
        Application.ScreenUpdating = True
        Sheets("CV DEN").Protect "bld"
End Sub

Ở đây mình muốn chỉnh sửa lại để có thể thực hiện được những công việc sau:
1. Nếu tên sheet là "CV DEN" hoặc là "THONG KE" thì không thực hiện hành động nào hết.

2. Nếu file đang ở chế độ Protect and share (có password) thì khi click vào tên các sheet (có tên khác sheet "CV DEN" hoặc "THONG KE") thì sẽ tự động tắt chức năng Protect and share, rồi thực hiện việc lọc dữ liệu từ sheet "CV DEN" chép qua. Sau khi thực hiện xong thì tự động bật chức năng Protect and share lại với password mặc định.

3. Có thể giới hạn chỉ xóa và copy nội dung của sheet "CV DEN" từ cột A --> Z, những cột còn lại của sheet được copy vẫn giữ nguyên nội dung (Mục đích là để lưu lại ghi chú kết quả thực hiện của từng người có liên quan để người văn thư cập nhật lại vào sheet "CV DEN").

Mình đính kèm theo file để mọi người dễ hình dung. rất mong được sự hướng dẫn và góp ý của các bạn. Thanks

 

[ChanhTQ@]

Macro của bạn đang còn lỗi ngay sau dòng On Error Resume Next

Bạn nên sửa lỗi này, sau đó mới tính tiếp

Option Explicit
Sub QQGPE()
 Dim strA As String, Vung As Range, jJ As Integer, Sh As Worksheet     '*'
 
 Application.ScreenUpdating = False
 strA = ActiveSheet.Name:                       Set Sh = Sheets("CV DEN") '*'
 Set Vung = Sh.[A5:X5]
 If strA <> "CV DEN" Then
   Sh.Unprotect "bld"
'   On Error Resume Next '
   jJ = Application.WorksheetFunction.Match(strA, Vung, 0)  '<=| Dòng Lenh Dang Sai, Dè Nghi Ban Xem & Sua Lai'
   ActiveSheet.Cells.Clear
   With Sh.Range(Sh.[a5], Sh.[a10000].End(xlUp)).Resize(, 21)
      ThisWorkbook.UnprotectSharing SharingPassword:="bld"
      .AutoFilter jJ, "x"
      .SpecialCells(12).Copy ActiveSheet.[a5]
      .AutoFilter
   End With
 End If
 Application.ScreenUpdating = True
 Sh.Protect "bld"
End Sub

 

[huuchuong1174]

Bạn nên sửa lỗi này, sau đó mới tính tiếp

Option Explicit
Sub QQGPE()
 Dim strA As String, Vung As Range, jJ As Integer, Sh As Worksheet     '*'
 
 Application.ScreenUpdating = False
 strA = ActiveSheet.Name:                       Set Sh = Sheets("CV DEN") '*'
 Set Vung = Sh.[A5:X5]
 If strA <> "CV DEN" Then
   Sh.Unprotect "bld"
'   On Error Resume Next '
   jJ = Application.WorksheetFunction.Match(strA, Vung, 0)  '<=| Dòng Lenh Dang Sai, Dè Nghi Ban Xem & Sua Lai'
   ActiveSheet.Cells.Clear
   With Sh.Range(Sh.[a5], Sh.[a10000].End(xlUp)).Resize(, 21)
      ThisWorkbook.UnprotectSharing SharingPassword:="bld"
      .AutoFilter jJ, "x"
      .SpecialCells(12).Copy ActiveSheet.[a5]
      .AutoFilter
   End With
 End If
 Application.ScreenUpdating = True
 Sh.Protect "bld"
End Sub

Sao mình chép đoạn code trên đè phần code của mình thì khi click vào các sheet khác ngoài sheet "CV DEN" thì không thấy thực hiện lọc dữ liệu bạn ơi. Bạn xem và chỉnh dùm nha. Thanks

 

[SA_DQ]

Bạn lấy macro này & chép đè lên macro ở ThisWorkBook, thử xem

Option Explicit
Private Sub Workbook_SheetActivate(ByVal Sh As Object)
 Dim A As String, Vung As Range, K As Integer, Sht As Worksheet
 
 Application.ScreenUpdating = False
 A = ActiveSheet.Name:                    Set Sht = Sheets("CV DEN")
 Set Vung = Sht.[A5:Z5]
 If A <> "CV DEN" And A <> "THONG KE" Then  '<=|'
   Sht.Unprotect "bld"
   On Error Resume Next
   K = Application.WorksheetFunction.Match(A, Vung, 0)
   ActiveSheet.Cells.Clear
   With Sht.Range(Sht.[a5], Sht.[a10000].End(xlUp)).Resize(, 26)
      ThisWorkbook.UnprotectSharing SharingPassword:="bld"
      .AutoFilter K, "x"
      .SpecialCells(12).Copy ActiveSheet.[a5]
      .AutoFilter
   End With
 End If
 Application.ScreenUpdating = True
 Sht.Protect "bld"
End Sub

 

[concogia]

Nhìn code này sao thấy "wen wen"

Option Explicit
Private Sub Workbook_SheetActivate(ByVal Sh As Object)
 Dim A As String, Vung As Range, K As Integer, Sht As Worksheet
 
 Application.ScreenUpdating = False
 A = ActiveSheet.Name:                    Set Sht = Sheets("CV DEN")
 Set Vung = Sht.[A5:Z5]
 If A <> "CV DEN" And A <> "THONG KE" Then  '<=|'
   Sht.Unprotect "bld"
   On Error Resume Next
   K = Application.WorksheetFunction.Match(A, Vung, 0)
   ActiveSheet.Cells.Clear
   With Sht.Range(Sht.[a5], Sht.[a10000].End(xlUp)).Resize(, 26)
      ThisWorkbook.UnprotectSharing SharingPassword:="bld"
      .AutoFilter K, "x"
      .SpecialCells(12).Copy ActiveSheet.[a5]
      .AutoFilter
   End With
 End If
 Application.ScreenUpdating = True
 Sht.Protect "bld"
End Sub

Chị Hải Yến ơi, em thấy code này mà dùng On eror ...là không ổn
"Thằng" K là tìm vị trí cột để filter, lúc đầu bài này chỉ có sheet "CV DEN" và 4 hay 5 sheet tên lãnh đạo gì đó (em quên mất rồi), đến lần sửa thứ 2 mới giống giống 'bi" giờ. Nếu thêm Sheet "THONG KE" thì cũng chẳng sao nhưng trừ 2 tên "CV DEN" & "THONG KE" thì tất cả tên sheet còn lại phải có tên trong vùng [A5:Z5]nên K luôn luôn > 0 ==> không được xảy ra lỗi ==> nếu lỗi là do tên sheet & tên trong "Vung" không giống nhau
Theo em, nếu xảy ra lỗi ở hàng đó thì nên sửa dữ liệu lại đến khi nào hết lỗi thi code mới chuyển đủ dữ liệu trong các sheet muốn chuyển

 

[chipsandcrisps]

Mình rất dốt về VBA nếu không nói là nát nhưng lại bắt đầu phải dùng đến nó trong công việc. Mình có đoạn code thế này các bác giải thích giúp. Trực tiếp trên diễn đàn hoặc nếu được thì mail cho mình thì càng tốt: chipsandcrisps@gmail.com. Mình cảm ơn nhiều lắm:

Sub VanDoi() ‘Activate sheet truoc tien
 Application.DisplayAlerts = False
 Dim xMax As Object, xDiem As Object
 Set xDiem = ThisWorkbook.ActiveSheet
 xDiem.Copy After:=xDiem
 Activesheet.Name= “VanDoi_TrichDiem” ‘Sua ten sheet vua duoc copy
 a = 0
 b = 0
 Set xMax = ActiveSheet
 r = 7
 Do
   For c = 6 To 62
     If Cells(r, c) <> "" Then
       vt = 1
       diem = Cells(r, c) & ";"
       vt1 = InStr(1, diem, ";")
       If vt1 > 0 Then
         diem1 = Val(Mid(diem, vt, vt1 - vt))
         vt = vt1 + 1
         Do
           vt1 = InStr(vt, diem, ";")
           a = 0
           If vt1 > 0 Then
             diem2 = Val(Mid(diem, vt, vt1 - vt))
             vt = vt1 + 1
             If diem1 < diem2 Then diem1 = diem2
           Else
             Cells(r, c) = diem1
             Exit Do
           End If
         b = 0
          a = 0
         Loop
       End If
     End If
   Next
   r = r + 1
   If Cells(r, 1) = "" Then Exit Do
 Loop
 End Sub

 

[anh2hn]

Chị Hải Yến ơi, em thấy code này mà dùng On eror ...là không ổn
"Thằng" K là tìm vị trí cột để filter, lúc đầu bài này chỉ có sheet "CV DEN" và 4 hay 5 sheet tên lãnh đạo gì đó (em quên mất rồi), đến lần sửa thứ 2 mới giống giống 'bi" giờ. Nếu thêm Sheet "THONG KE" thì cũng chẳng sao nhưng trừ 2 tên "CV DEN" & "THONG KE" thì tất cả tên sheet còn lại phải có tên trong vùng [A5:Z5]nên K luôn luôn > 0 ==> không được xảy ra lỗi ==> nếu lỗi là do tên sheet & tên trong "Vung" không giống nhau
Theo em, nếu xảy ra lỗi ở hàng đó thì nên sửa dữ liệu lại đến khi nào hết lỗi thi code mới chuyển đủ dữ liệu trong các sheet muốn chuyển

Đúng nên là (như thế chuyển sang vị trí chuẩn hơn)

On Error Go to ....