nhưng em sửa rồi mà vẫn chưa chạy dược anh ơi
xlFilterValues chứ không phải là x1filterValues, copy code mà còn sai.
Cái video này nó lọc ở cột A mà bạn. Theo bạn mô tả hình như là lọc cột C thì phải. nếu đúng vậy thì bạn có thể sử dụng code sau.
Private Sub textbox1_change()
ActiveSheet.Range("$A$3:$I$" & Range("A65000").End(xlUp).Row).AutoFilter Field:=3, Criteria1:="*" & [b2] & "*"
End SubBạn dùng code này cho file của bạn.
Sub GPE()
On Error Resume Next
Dim i As Long, VungDel As Range, k As Long
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
k = 0
For i = Sheet1.Range("A65000").End(xlUp).Row To 5 Step -1
If WorksheetFunction.CountBlank(Sheet1.Range("A" & i).Resize(, 9)) = 9 Then
If VungDel Is Nothing Then
Set VungDel = Rows(i)
Else
Set VungDel = Union(VungDel, Rows(i))
k = k + 1
If (k = 100) And (Not VungDel Is Nothing) Then
VungDel.EntireRow.Delete
Set VungDel = Nothing
k = 0
End If
End If
End If
Next i
If Not VungDel Is Nothing Then VungDel.EntireRow.Delete
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
Trong code có chỗ SearchDirection:=xlNext, sửa lại thành SearchDirection:=xlPrevious thì nó sẽ tìm từ dưới lên
Em cảm ơn thầy
Trong code bạn ghì: Cells.Find(....) có nghĩa là tìm trên toàn bộ bảng tính? Như vậy không tốt lắm, bời tên cty nằm ở cột C mà
Sub Button2_Click()
On Error Resume Next
Range("C5:C10000").Find(Range("C2").Value, , xlValues, xlPart, , xlPrevious, False).Select
End Sub
Thầy Ndu! chỉnh lại hộ em đoạn code file dưới với ạ. đoạn code mọi khi em vẫn dùng, nhưng hnay giữ liệu nhiều hơn bị lỗi khả năng do vùng làm việc nhỏ quá nên lỗi nhờ thầy xem cho em với..
Trên đầu code có:
dArr(1 To 1000, 1 To 7)dArr(1 To 10000, 1 To 7)Hihi. Có cái "CỦA QUÝ". Thầy vui tính thật.!
Bạn thử như vầy xem::
Sub Button1_Click()
Dim LastRow As Long
LastRow = Range("A" & Cells.Rows.Count).End(xlUp).Row + 1
Rows(LastRow & ":1000").Clear
' Hoặc:'
'Rows(LastRow & ":1000").EntireRow.Delete'
End Sub
xin giúp mình làm file update file nguồn mà file nguồn không cần mở lên lên để update dữ liệu
Sub Macro1()
'
' Macro1 Macro
'
'
Range("R10").Select
ActiveCell.FormulaR1C1 = "=IF(COUNTIF(R10C3:RC[-15],RC[-15])>1,"""",RC[-15])"
Range("R10").Select
Selection.AutoFill Destination:=Range("R10:R2650"), Type:=xlFillDefault
Range("R10:R2650").Select
Selection.AutoFilter
ActiveSheet.Range("$R$10:$R$2650").AutoFilter Field:=1, Criteria1:=Array( _
"5-T-TP-DDK", "8-TCLT-TP-DDK", "A300", "A300- viê`n khung bao", _
"C101A-T0.9 (18.2x16)", "C1687 (60x14.2)", "C1697 (60x25.3)", "C3033", _
"C3033 (51x52.4x1.4)", "C3202 (54.8x76)", "C3202A-T1.2 (54.8x76)", _
"C3203 (54.8x68)", "C3203-T1.2 (54.8x68)", "C3209 (54.8x50)", _
"C3209-T1.2 (54.8x50)", "C3295 (37.3x23.5)", "C3303 (54.8x87)", _
"C3303-T1.2 (54.8x87)", "C3304 (54.5x138)", "C3304-T1.2 (54.5x138)", _
"C3313 (54.8x68)", "C3313-T1.2 (54.8x68)", "C3318 (54.8x50)", _
"C3318-T1.2 (54.8x50)", "C3323-T1.2 (50x57.2)", "C3328-T1.2 (54.8x66)", _
"C3329 (40.7x21.6)", "C3332 (54.8x87)", "D1541A-T1.2(93.4x40)", _
"D1541A-T2.0 (93.4x40)", "D1543A-T1.2 (98x34)", "D1543A-T2.0 (98x34)", _
"D1544A-T1.2 (28.9x50)", "D1544A-T2.0 (28.9x50)", "D1545A-T1.2(28.9x61.5)", _
"D1546A-T1.2 (62x33.7)", "D1546A-T2.0 (62x33.7)", "D1546C-T2.0 (85x33.7)", _
"D1547A-T1.2 (50x39.2)", "D1547A-T2.0 (50x39.2)", "D1547C-T2.0 (85x39.2)", _
"D1548A-T2.0 (39.5x20)", "D1549A-T2.0 (98x21.3)", "D1551A-T1.8 (93.4x62.8)", _
"D1555A-T1.2 (28.9x71.5)", "D1555A-T2.0 (28.9x71.5)", "D1559A-T2.0 (93.4x38.8)", _
"D17182-T1.2 (93.4x25.5)", "D17182-T2.0 (93.4x25.5)", "D17182-T2.0 (93.4x40)", _
"D2618A-T2.0 (92.4x50.6)", "DA2006 (19x19x0.8)", "DA3001 (100.3X9.8)", _
"ÐGCBG-HH,L,T", "DK-5", "DLM", "EP041K", "EP163K", "F347 (95x31.6)", "GO-GC55", _
"GO-GC56", "KB", "KEG", "KTC", "MTC-UK", "NBM3.9", "NC-UK", "NDV", "NRS", "TCVLD-5", _
"Vi3,9x19", "Vi3,9x40", "VN-M5x70", "ZL.3x9 (SP3x9)", "ZL.7x5 (SP7x5)"), Operator _
:=xlFilterValues
Selection.Copy
Sheets("THVT").Select
Range("C9").Select
ActiveSheet.Paste
ActiveWindow.SmallScroll Down:=-6
Sheets("PTVT").Select
Application.CutCopyMode = False
Selection.ClearContents
Selection.ClearContents
Selection.ClearContents
ActiveWindow.SmallScroll Down:=-24
Sheets("THVT").Select
Range("G9").Select
ActiveCell.FormulaR1C1 = "=SUMIF(PTVT!C3,THVT!RC[-4],THVT!C[2])"
Range("G9").Select
ActiveCell.FormulaR1C1 = "=SUMIF(PTVT!C3,THVT!RC[-4],PTVT!C[2])"
Range("G9").Select
Selection.AutoFill Destination:=Range("G9:G84"), Type:=xlFillDefault
Range("G9:G84").Select
ActiveWindow.SmallScroll Down:=-54
Range("H9").Select
ActiveCell.FormulaR1C1 = "=VLOOKUP(RC[-5],PTVT!R10C3:R2650C17,8,0)"
Range("H9").Select
Selection.AutoFill Destination:=Range("H9:H84"), Type:=xlFillDefault
Range("H9:H84").Select
ActiveWindow.SmallScroll Down:=-57
Range("I9").Select
ActiveCell.FormulaR1C1 = "=VLOOKUP(RC[-6],PTVT!R9C3:R2650C17,1,0)"
Range("I9").Select
ActiveCell.FormulaR1C1 = "=VLOOKUP(RC[-6],PTVT!R9C3:R2650C17,10,0)"
Range("I9").Select
Selection.AutoFill Destination:=Range("I9:I84"), Type:=xlFillDefault
Range("I9:I84").Select
ActiveWindow.SmallScroll Down:=-39
Range("J9").Select
ActiveCell.FormulaR1C1 = "=VLOOKUP(RC[-7],PTVT!R9C3:R2650C17,12,0)"
Range("J9").Select
Selection.AutoFill Destination:=Range("J9:J84"), Type:=xlFillDefault
Range("J9:J84").Select
ActiveWindow.SmallScroll Down:=-84
Range("K9").Select
ActiveCell.FormulaR1C1 = ""
Range("L9").Select
ActiveCell.FormulaR1C1 = "=VLOOKUP(RC[-9],PTVT!R10C3:R2650C17,14,0)"
Range("L9").Select
Selection.AutoFill Destination:=Range("L9:L84"), Type:=xlFillDefault
Range("L9:L84").Select
ActiveWindow.SmallScroll Down:=-39
Range("J25").Select
End Sub
If Insulator = "PVC" Then
Select Case Core
Case "1C"
For i = 1 To 16
If AreaConductor = ThisWorkbook.Worksheets(1).Cells(i + 7, "A") Then
DK = ThisWorkbook.Worksheets(1).Cells(i + 7, "E")
End If
Exit For
Case "2C"
For i = 1 To 16
If AreaConductor = ThisWorkbook.Worksheets(1).Cells(i + 7, "R") Then
DK = ThisWorkbook.Worksheets(1).Cells(i + 7, "AB")
End If
Exit For
Case "3C"
For i = 1 To 16
If AreaConductor = ThisWorkbook.Worksheets(1).Cells(i + 7, "AI") Then
DK = ThisWorkbook.Worksheets(1).Cells(i + 7, "AS")
End If
Exit For
Case "4C"
For i = 1 To 16
If AreaConductor = ThisWorkbook.Worksheets(1).Cells(i + 7, "AI") Then
DK = ThisWorkbook.Worksheets(1).Cells(i + 7, "BJ")
End If
Exit For
End Select
End If
Function SplitProvince(ByVal Province As String, ByVal delimiter As String) As String
Dim intdem As Integer
Dim intPos As Integer
For intdem = Len(Trim(Province)) To 1 Step -1
If Mid(Province, intdem, 1) = delimiter Then
intPos = intdem
Exit For
End If
Next intdem
SplitProvince = Trim(Right(Province, Len(Province) - intdem))
End FunctionSub test()
Cells(1, 2).Value = SplitProvince((Range("A1").Value), ",")
End SubThì đương nhiên không chạy rồi. Ngoài bảng tính anh Bill có hiểu text là cái giống gì đâu chứ
Function SplitProvince(ByVal Province As String, ByVal delimiter As String) As String
Dim sArr() As String
sArr = Split(Province, delimiter)
SplitProvince = sArr(UBound(sArr, 1))
End FunctionOption Explicit
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Dim rTarget As Range, aTarget, i As Long, n As Long
Dim Arr1(), Arr2(), Arr3(), tmp
On Error Resume Next
If Dic Is Nothing Then Auto_Open
If Not Intersect(Range("C6:C10000"), Target) Is Nothing Then
Set rTarget = Intersect(Range("C6:C10000"), Target)
If IsArray(rTarget.Value) Then
aTarget = rTarget.Value
...Sub TestSendEmail()
Dim OutApp As Object
Dim OutMail As Object
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = "hoang.xuan@gmail.com"
.CC = ""
.BCC = ""
.Subject = "Arrival Notice" & " " & Range("A2").Value & " " & Range("B2").Value & " " & Range("C2").Value & " " & Range("D2").NumberFormat
.Body = "Please kindly see attached file"
.Attachments.Add (Range("C6").Value & Range("A2").Value & ".pdf")
.Send
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
MsgBox ("ARRIVAL NOTICE IS SENT TO CUSTOMER")
End SubDùng InStrRev như bài 753 gợi ý sẽ tốt hơn
Function SplitProvince(ByVal Province As String, ByVal delimiter As String) As String
Dim sArr() As String
If InStr(1, Province, delimiter, vbTextCompare) Then
sArr = Split(Province, delimiter, , vbTextCompare)
SplitProvince = sArr(UBound(sArr))
End If
End FunctionFunction SplitProvince(ByVal Province As String, ByVal delimiter As String) As String
Dim lPos As Long
lPos = InStrRev(Province, delimiter, , vbTextCompare)
If lPos Then SplitProvince = Trim(Mid(Province, lPos + Len(delimiter)))
End FunctionFunction SplitProvince(ByVal Province As String, ByVal delimiter As String, Optional ByVal CompareMode = vbTextCompare) As String
Dim lPos As Long
lPos = InStrRev(Province, delimiter, , CompareMode)
If lPos Then SplitProvince = Trim(Mid(Province, lPos + Len(delimiter)))
End FunctionBạn thêm đoạn code này vào đầu thủ tục, cái này sẽ làm cho nó không tác động vào sheet1.
if sh is sheet1 then exit subBạn tải code trong video về, và cấu hính như video là chạy được luôn.
Sub Copy_Database()
Application.ScreenUpdating = False
Application.AskToUpdateLinks = False
Application.DisplayAlerts = False
Application.Calculation = xlCalculationManual
Range("A7:Z60000").ClearContents
Dim rngVung As Range
Dim strPath As String
Dim fileName As String
Dim NameFile As String
strPath = Range("H1").Value
fileName = Dir(strPath & "*.xls*")
NameFile = ThisWorkbook.Name
Do While fileName <> ""
Workbooks.Open (strPath & fileName)
ActiveWorkbook.ActiveSheet.Select
If Application.WorksheetFunction.CountA(Range("A2:A60000")) > 0 Then
Range("A2", Range("A60000").End(xlUp).Offset(0, 25)).Copy ' Copy data Each a File
Workbooks(NameFile).Sheets("Database").Range("A60000").End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues ' Paste vao File tong hop
End If
Application.CutCopyMode = False
ActiveWorkbook.Close SaveChanges:=False
fileName = Dir()
Loop
Application.ScreenUpdating = True
Application.Calculation = xlAutomatic
Application.DisplayAlerts = True
End SubChả hiểu chi nữa, thử sửa cái này xem có đúng không?
Private Sub DisplayTimer()
Dim i As Long
If Not Pause Then
If Min = 0 And Sec <= 0 ThenHihi. Cảm ơn ạ. Chạy lùi về 0:00 ổn rồi ạ. Chỉ còn phần thời gian nghỉ giữa hiệp bị trễ mất 1s lúc đầu thôi ạ. Tiếp tục nhờ trợ giúp của mọi người.
Code AddIn kiểu này chắc chắn không hoạt động, bởi Sub Aut
pen chỉ chạy 1 lần duy nhất khi kích hoạt AddIn mà thôi, và code sẽ không "nhìn" thấy được các file mở sau đóPublic WithEvents ExlApp As Application
Private Sub Class_Initialize()
Set ExlApp = Application
End Sub
Private Sub Class_Terminate()
Set ExlApp = Nothing
End Sub
Private Sub ExlApp_WorkbookOpen(ByVal Wb As Workbook)
If UCase(Right(Wb.FullName, 3)) = "XLS" Then
MsgBox "HE THONG KHÔNG HO TRO MO DINH DANG FILE NÀY"
Wb.Close False
End If
End SubDim ExlObj As New clsWkbEvents
Sub Auto_Open()
If ExlObj Is Nothing Then Set ExlObj = New clsWkbEvents
End Sub
Sub Auto_Close()
Set ExlObj = Nothing
End SubCode AddIn kiểu này chắc chắn không hoạt động, bởi Sub Aut
Muốn làm được yêu cầu trên phải dùng Class. Quy trình như sau:
1> Chèn 1 Class Module, đặt tên là clsWkbEvents
Code trong Class Module:
2> Chèn 1 Module đặt tên tùy ý, với code:Mã:Public WithEvents ExlApp As Application Private Sub Class_Initialize() Set ExlApp = Application End Sub Private Sub Class_Terminate() Set ExlApp = Nothing End Sub Private Sub ExlApp_WorkbookOpen(ByVal Wb As Workbook) If UCase(Right(Wb.FullName, 3)) = "XLS" Then MsgBox "HE THONG KHÔNG HO TRO MO DINH DANG FILE NÀY" Wb.Close False End If End Sub
Giờ Save As file thành XLAM, kích hoạt AddIn và test thửMã:Dim ExlObj As New clsWkbEvents Sub Auto_Open() If ExlObj Is Nothing Then Set ExlObj = New clsWkbEvents End Sub Sub Auto_Close() Set ExlObj = Nothing End Sub
Thầy ơi, chưa lần nào thầy sửa giúp e cả. Hix..Code AddIn kiểu này chắc chắn không hoạt động, bởi Sub Aut
Muốn làm được yêu cầu trên phải dùng Class. Quy trình như sau:
1> Chèn 1 Class Module, đặt tên là clsWkbEvents
Code trong Class Module:
2> Chèn 1 Module đặt tên tùy ý, với code:Mã:Public WithEvents ExlApp As Application Private Sub Class_Initialize() Set ExlApp = Application End Sub Private Sub Class_Terminate() Set ExlApp = Nothing End Sub Private Sub ExlApp_WorkbookOpen(ByVal Wb As Workbook) If UCase(Right(Wb.FullName, 3)) = "XLS" Then MsgBox "HE THONG KHÔNG HO TRO MO DINH DANG FILE NÀY" Wb.Close False End If End Sub
Giờ Save As file thành XLAM, kích hoạt AddIn và test thửMã:Dim ExlObj As New clsWkbEvents Sub Auto_Open() If ExlObj Is Nothing Then Set ExlObj = New clsWkbEvents End Sub Sub Auto_Close() Set ExlObj = Nothing End Sub
Dán đoạn code này vào thisworkbook là được.
Dim WithEvents app As Excel.Application
Private Sub app_WorkbookOpen(ByVal Wb As Workbook)
On Error Resume Next
If Application.Workbooks.Count >= 2 Then
If Strings.UCase(Strings.Right$(Wb.Name, 3)) = "XLS" Then
MsgBox "He thong khong ho tro loai file nay"
Wb.Close False
End If
End If
End Sub
Private Sub Workbook_BeforeClose(Cancel As Boolean)
'Set app = Nothing
End Sub
Private Sub Workbook_Open()
Set app = Application
End SubỞ #768 thầy ơi. Thầy xem giúp chỉnh em với. Hihi.
thế có xem cái bài làm của em chưa? quảng cáo đâu.
myFunction không biết nó là cái gì nữa.
Sub Find_First()
Dim FindString As String
Dim Rng As Range
Dim FistAddress As String
Dim LastAddress As String
Dim Result As Range
Dim ws As Worksheet
Dim firstAdd As String
' Xóa dong trong trong sheet NET
Sheets("NET").Select
Range("A4").Select
Range(Selection, Selection.End(xlDown)).Select
Application.CutCopyMode = False
Selection.EntireRow.Delete
'Tim gia tri dau tien
FindString = InputBox("Can Tim Kiem Cai Gi:", "Tra Cuu")
If Trim(FindString) <> "" Then
With Sheets("Sheet1").Range("C:D")
Set Rng = .Find(What:=FindString, _
After:=.Cells(.Cells.Count), _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
firstAdd = Rng.Address
If Not Rng Is Nothing Then
Application.Goto Rng, True
Cells(Rng.Row, 13).Value = 1
FistAddress = Rng.Row
Else
MsgBox "Nothing found"
End If
End With
'Tim gia tri cuoi cung
With Sheets("Sheet1").Range("C:D")
Do
Set Rng = .Find(What:=FindString, _
After:=.Cells(1), _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False)
If Not Rng Is Nothing Then
'Rng = Cells(LastAddress, 3)
'Set Rng = .FindNext(Rng)
Application.Goto Rng, True
Cells(Rng.Row, 13).Value = 2
LastAddress = Rng.Row
'MsgBox Cells(Rng.Row, 11)
'MsgBox Cells(Rng.Row, 3)
Set Rng = Cells(LastAddress, 3)
Set Rng = .FindNext(Rng)
FindString = Cells(LastAddress, 3)
Else
MsgBox "Nothing found"
End If
Loop While firstAdd <> Rng.Address And Cells(Rng.Row, 11) > 600
'Copy sang Sheet NET
Set Result = Range(Cells(FistAddress, 1), Cells(LastAddress, 12))
Result.Select
Selection.Copy Destination:=Sheets("NET").Range("A4")
Sheet23.Activate
End With
End If
End SubSub sosanh()
Dim i As Integer
Dim a, b As Integer
Sheets("1").Select
a = Application.WorksheetFunction.RandBetween(1, 3)
b = Application.WorksheetFunction.RandBetween(1, 3)
Do
Calculate
Loop until (a = b)
MsgBox "gia tri a va b la: " & a &" "& b
End Sub
Viết cái gì không hiểu luôn. Ngắt ý ở chỗ nào trong câu trên?
a = Application.WorksheetFunction.RandBetween(1, 3)
b = Application.WorksheetFunction.RandBetween(1, 3)
Do
Calculate
Loop until (a = b)Vầy thử xem:
Sub Test()
Dim a As Long, b As Long
Randomize
Do
a = Int(Rnd() * 3) + 1
b = Int(Rnd() * 3) + 1
Loop Until (a = b)
MsgBox "gia tri a va b la: " & a & " " & b
End SubMới học vba nên bị ngộ nhận. a và b trong trường hợp này chỉ được tính duy nhất một lần, Chạy cái này thì xác xuất treo máy là rất cao.
1/ Cho code vào thẻ chèn code. Tìm đọc ở mục 4 màu đỏ ở link
- Bạn chèn đoạn code sau vào cái nút Submit Form.
Private Sub btnSubmit_Click()
Dim cbName As Variant
Dim rFind As Range
cbName = UserForm1.cmbName.Value
If cbName = "" Then
MsgBox "Ban chu nhap Ten vao", vbCritical, "Chu Y"
ElseIf cbName <> "" Then
Set rFind = Sheets("Sheet2").Range("D2:D1000").Find(cbName, LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=True)
If Not rFind Is Nothing Then
txtAddress = rFind.Offset(0, 1).Value
txtPhone = rFind.Offset(0, 2).Value
txtZipcode = rFind.Offset(0, 3).Value
Else
txtAddress = ""
txtPhone = ""
txtZipcode = ""
MsgBox "Not Found"
End If
End If
End Sub
1000"). Nếu không tìm thấy Name trong Sheet2.Range("D21000") thì user có thể Add mới thông tin cần nhập vào qua nút Submit Form.1000) hay không.
Sheets("Sheet1").Range("A1:Z71")
