Đúng rồi, mình mới thử các form khác nếu ko có frx thì ko import được. Vậy là bó tay luôn phải ko bạn?
Mình đang làm thử như vậy nhưng cũng chưa được. Cố gắng thử ( mới tập tành xem code), cám ơn bạn đã xem bài.
Sao lại chưa được?
sao khi copy code, cho nó chạy thử. control nào thiếu sẽ được thông báo, rồi từ đó thêm. khó ở cái không biết cần chỉnh thuộc tính như thế nào.
Mình đang làm thì phát sinh lỗi. bạn cũng đã sửa giúp mình 1 lỗi ở bên http://www.giaiphapexcel.com/diendan/threads/sữa-lỗi-runtime-error-424.55239/#post-835062 rồi đó.
Tất nhiên phải làm thế. Nhưng để làm chuẩn thì nhiều khi bó tay. Vì có thể có Image (chẳng hạn Logo) và rất nhiều Label - vd. tiêu đề các cột của ListBox v...v Những control này không xuất hiện trong code nên thiếu cũng không biết.
Hi vọng không phức tạp. Mới ngang listbox mà thấy lỗi tùm lum luôn.
File của bạn không có Code VBA thì làm sao "xử lý, gỡ rối" trong chuyên mục này? Chỉ có là "viết dùm".
D3=IF((C3-A3)<=B3;"X";"")
E3=IF(D3="";C3-A3-B3;"")
'Copy xuống mõi tay thì thôi'Cảm ơn bạn, dùng hàm thì mình làm được nhưng dung lượng quá nặng vì mình làm tới trên cả ngàn dòng. Mình thì không biết về code nên lên đây nhờ ae giúp hộ.
Sub ThoiHanThucHien()
Dim Rws As Long, J As Long, Tre As Integer
Rws = [B2].End(xlDown).Row
If Rws < 3 Then Exit Sub
For J = 3 To Rws
With Cells(J, "A")
Tre = .Offset(, 2).Value - (.Value + .Offset(, 1).Value)
If Tre < 1 Then
.Offset(, 3).Value = "GPE.COM"
Else
.Offset(, 4).Value = Tre
End If
End With
Next J
End SubLỗi variable not defined là chưa khai báo biến. Bạn chạy bằng F8 thì đến dòng nó báo thông báo đó bạn kiểm tra lại xem biến nào chưa khai báo.
Lỗi ở dòng màu đỏ đó bạn.
đổi tên cái listbox trong form thành lstdmcv
listbox trong form là lstDMCV rồi đó bạn
Nếu thêm biên dim As Long vào thì lỗi tiếp ở dòng ChenMaDonGia.......
Code trong file bạn làm thiếu thốn đủ thử, do là bản chế lại nên nó thế. cái dim i as long là phải có. Do sự thiếu thốn đó mà cứ sửa hết lỗi này thì lỗi mới lại xuất hiện. Cụ thể là cái ChenMaDonGia cũng không có trong code. Tìm trong file gốc xem có cái ChenMaDonGia không thì copy nó vào là được, nhưng chắc chắn là lại xuất hiện các lỗi mới. NÓi cung là còn dài dài.
Mình đã làm được nút "chen" rồi, cám ơn bạn.
Private Sub CheckCmdThem()
Cái này là textbox, đổi tên nó như listbox là được.
Đoạn code này nghĩa là gì vậy bạn?
Đoán là vô hiệu hóa hay cho phép các textbox làm việc. Tìm hiểu cái thuộc tính TabIndex sẽ rõ hơn.
Bạn
Làm thế nào để chạy được code bắt đầu thủ tục "Public Sub......." vậy bạn?
Gõ tên của nó ra.
Ví dụ với đoạn code sau, mình không đưa vào macro được.
Mình thấy bạn nên lập một bài viết mới, nêu rõ hoàn cảnh, nhờ các thành viên khôi phục lại cái form hỏng ý cho. Chứ bạn tự làm chắc phải sang năm mới xong, không hiệu quả. Thớt này chỉ rành cho những vấn đề nổi cộm, code bị lỗi bị vướng ở một vài chỗ thì trao đổi ở đây. Của bạn là một vấn đề lớn quá sức.
Cám ơn bạn đã nhắc, phần form đó cũng tương đối rồi.
Cái phần ngay sau cái từ Sub là phần quan trọng để xác định cách gọi nó thì bạn cắt gọn mất (xem bên dưới)
Chỉ làm được nếu nó khong có tham số bắt buộc
Sub này có cái dãy tham đi kế nó cho nên mỗi lần chạy, nó bắt buộc phải nạp đủ đám tham đó (2 tham). Ví dụ:
Sub ReplaceInFolder()
Dim strPath As String
Dim strFile As String
Dim wbk As Workbook
Dim wsh As Worksheet
Dim strFind As String
Dim strReplace As String
strFind = InputBox("Enter text to find")
If strFind = "" Then
MsgBox "No find text specified!", vbExclamation
Exit Sub
End If
strReplace = InputBox("Enter replacement text")
With Application.FileDialog(msoFileDialogFolderPicker)
If .Show Then
strPath = .SelectedItems(1)
Else
MsgBox "No folder selected!", vbExclamation
Exit Sub
End If
End With
If Right(strPath, 1) <> "\" Then
strPath = strPath & "\"
End If
Application.ScreenUpdating = False
strFile = Dir(strPath & "*.xls*")
Do While strFile <> ""
Set wbk = Workbooks.Open(Filename:=strPath & strFile, AddToMRU:=False)
For Each wsh In wbk.Worksheets
wsh.Cells.Replace What:=strFind, Replacement:=strReplace, _
LookAt:=xlWhole, MatchCase:=False
Next wsh
wbk.Close SaveChanges:=True
strFile = Dir
Loop
Application.ScreenUpdating = True
End Sub
Đọc kiểu code là biết nguồn của KuTools đem về chế lại.
Anh ơi, copy cái đoạn code của anh vào đâu hả anh. Anh thông cảm, em biết ít kiến thức lắm. Em chỉ biết copy code đã viết sẵn rồi dùng thui
Không biết code mà cứ thích dùng code.
Sub DisplayedToActual()
'Updateby20131126
Dim Rng As Range
Dim WorkRng As Range
On Error Resume Next
xTitleId = "Hoc Excel Online"
Set WorkRng = Application.Selection
Set WorkRng = Application.InputBox("Range", xTitleId, WorkRng.Address, Type:=8)
Application.ScreenUpdating = False
For Each Rng In WorkRng
If Rows(Rng.Row).EntireRow.Hidden = False Then
Rng.Value = Rng.Text
End If
Next
Application.ScreenUpdating = True
End SubEm cám ơn anh. Cho em hỏi ngu thêm câu nữa là, em có sưu tầm đc 2 code để phục vụ công việc ( code này là cái thứ 3 ) em muốn nó thành 1 tool add in (hoặc 3 tool riêng biệt cũng được) trên thanh toolbar để dùng khi cần thì làm như thế nào ạ. Hiện tại cần gì em toàn phải xoá cái cũ đi để thêm cái mới vào
Cần lên khung search và gõ tool addin bạn
Nếu bạn muốn lưu làm công cụ để tiện thao tác bạn lưu file tên là.XLSA
Xem file
Nội dung theo dõi về tố cáo, khiếu nại trước đây (khoảng 7 năm) tôi viết hẳn 1 File theo dõi cho cơ quan, nhưng rất tiếc cơ quan không dùng (lý do đã có phần mềm theo dõi), để tôi tìm lại và sửa cho phù hợp cái bạn cần. Vậy, bạn hãy chờ tôi tìm (giờ không nhớ để nó ở cái xó nào).
Em cám ơn anh, em chưa thấy ở đâu mọi người nhiệt tình như ở GPE
Em cám ơn anh. Nhưng mỗi lần em xuất file từ phần mềm ra excel tên sheet sẽ không là "Before" và "After" ( em đặt vậy để trình bày cho mọi người dễ hiểu ). Có cách nào mà mình chạy thì nó cho sang sheet mới không anh ? Cột mã số em làm text to colums theo cột cũng nhanh thôi.
Tên sheet xuất từ phần mềm cố định hay thay đổi? tên sheet tạo mới đặt tên như thế nào?
Vậy thì bạn nên đưa vài cái File xuất từ phần mềm ra excel lên đây thử xem, biết quy luật thì mới tính tiếp được.
Tên sheet thì sẽ là tên file mình đặt, mình đặt gì cũng đc. Chỉ có 1 sheet duy nhất giống như sheet “before” đó ạ. Tuy nhiên nếu hiện tại ( dùng code của anh HieuCD ) khi em export file mới, em sẽ phải xoá các cột đi để lấy đc hàng tiêu đề mẫu và copy sang sheet mới và đặt tên là after. Em cám ơn
Sub CopyData()
Dim Rng As Range
Dim Id As Long, i As Long, lRow As Long
Const Str = "Personnel Number:"
Application.ScreenUpdating = False
Sheets("Before").Copy After:=Sheets(Sheets.Count)
ActiveSheet.Name = "After" & Sheets.Count - 1 'Chinh lai tên Sheet
lRow = Range("C" & Rows.Count).End(xlUp).Row
Set Rng = Cells(1, 1)
For i = 2 To lRow
If Cells(i, 2) = Str Then Id = Cells(i, 7)
If IsNumeric(Mid(Cells(i, 3), 1, 2)) Then
Cells(i, 2) = Id
Else
If i <> 11 Then Set Rng = Union(Rng, Cells(i, 1))
End If
Next i
Rng.EntireRow.Delete
Range("A:A,E:E,I:I,N:N,P:P,R:X,Z:Z,AB:AB,AD:AF,AO:AQ,BA:BA").EntireColumn.Delete
Set Rng = Nothing
Application.ScreenUpdating = True
End Sub
Code vậy không được vì sẽ bị tham chiếu vòng. Cứ gán giá trị trực tiếp luôn thay vì gán công thức
Private Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = False
If Target.Row >= 9 And Target.Row <= 16 Then
If Target.Column = 6 Then Target.Offset(, -2).Value = Target.Value
If Target.Column = 4 Then Target.Offset(, 2).Value = Target.Value
End If
Application.EnableEvents = True
End SubPrivate Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = False
If Target.Row >= 9 And Target.Row <= 16 Then
If Target.Column = 6 Then
With Target.Offset(, -2)
.FormulaR1C1 = "=INDEX(R9C10:R16C10,MATCH(RC[2],R9C11:R16C11,0))"
.Value = .Value
End With
End If
If Target.Column = 4 Then
With Target.Offset(, 2)
.FormulaR1C1 = "=INDEX(R9C11:R16C11,MATCH(RC[-2],R9C10:R16C10,0))"
.Value = .Value
End With
End If
End If
Application.EnableEvents = True
End SubCảm ơn bạn.
Tôi chưa rảnh để tìm File, bạn vào tải File ở bài 130 của Link sau xem có dùng được không? Tôi nghĩ thêm bớt 1 chút là dùng được.
Vẫn quan điểm ở trên: Tuyệt đối không nên gán công thức vào Target khi thực hiện sự kiện Change (dễ bị lỗi) mà nên tính toán trực tiếp trong code
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rngFind As Range, cel As Range
Dim lOffset1 As Long, lOffset2 As Long, lOffset3 As Long
Application.EnableEvents = False
On Error Resume Next
If Target.Row >= 9 And Target.Row <= 16 Then
If Target.Column = 4 Then lOffset1 = 1
If Target.Column = 6 Then lOffset1 = -1
If lOffset1 Then
lOffset2 = (1 - lOffset1) / 2
lOffset3 = lOffset1 * 2
For Each cel In Target
If cel.Column = 4 Or cel.Column = 6 Then
Set rngFind = Range("DANHSACH").Resize(, 1).Offset(, lOffset2).Find(cel.Value, , xlValues, xlWhole)
If Not rngFind Is Nothing Then
cel.Offset(, lOffset3).Value = rngFind.Offset(, lOffset1).Value
Else
cel.Offset(, lOffset3).ClearContents
End If
End If
Next
End If
End If
If Err.Number Then MsgBox Err.Description
Application.EnableEvents = True
End Sub
With ShTrangChu.Range("g3:g66" & [f66].End(3).Row)
.Value = "=IF(RC[-1]=0,0,HLOOKUP(R2C2,Data!R2C3:R180C250,MATCH(RC[-1],Data!R2C2:R198C2,0),0))"
.Value = "'" & .Value
End WithXem lại cái này là cái gì
With ShTrangChu.Range("g3:g66" & [f66].End(3).Row) With ShTrangChu.Range("g3:g"& [f65000].End(3).Row)Ban đầu code là như bạn sửa á, mình muốn chèn hàm JointText vào cell G67 để nó joint các text nằm ở các ô khác, nhưng khi chạy thì nó copy công thức xuống toàn bộ các cell trong cột G. Nên mình sửa lại thành như code mình đăng lên.
With ShTrangChu.range (G67)
.value = "Jointext (",", G8, G13:G23)"
.value = .value
End withChỗ nào là text được đặt trong cặp nháy đôi thì khi đưa vào VBA phải sửa 1 dấu nháy đôi thành 2 dấu
.value = "=Jointext("","",G8,G13:G23)"Khỏi cần ghi tên sheet hay tên workbook thì Excel sẽ hiểu đó là ActiveSheet và ActiveWorkbook
Sub Test()
With Range("A1:B1000")
.Sort .Cells(1, 2), xlDescending, .Cells(1, 1), , xlDescending, , , xlNo
End With
End SubCẢM ƠN ANH.
Bạn thêm code sau vào Module.
Function ConvertToUnSign(ByVal sContent As String) As String
Dim i As Long
Dim intCode As Long
Dim sChar As String
Dim sConvert As String
ConvertToUnSign = AscW(sContent)
For i = 1 To Len(sContent)
sChar = Mid(sContent, i, 1)
If sChar <> "" Then
intCode = AscW(sChar)
End If
Select Case intCode
Case 273
sConvert = sConvert & "d"
Case 272
sConvert = sConvert & "D"
Case 224, 225, 226, 227, 259, 7841, 7843, 7845, 7847, 7849, 7851, 7853, 7855, 7857, 7859, 7861, 7863
sConvert = sConvert & "a"
Case 192, 193, 194, 195, 258, 7840, 7842, 7844, 7846, 7848, 7850, 7852, 7854, 7856, 7858, 7860, 7862
sConvert = sConvert & "A"
Case 232, 233, 234, 7865, 7867, 7869, 7871, 7873, 7875, 7877, 7879
sConvert = sConvert & "e"
Case 200, 201, 202, 7864, 7866, 7868, 7870, 7872, 7874, 7876, 7878
sConvert = sConvert & "E"
Case 236, 237, 297, 7881, 7883
sConvert = sConvert & "i"
Case 204, 205, 296, 7880, 7882
sConvert = sConvert & "I"
Case 242, 243, 244, 245, 417, 7885, 7887, 7889, 7891, 7893, 7895, 7897, 7899, 7901, 7903, 7905, 7907
sConvert = sConvert & "o"
Case 210, 211, 212, 213, 416, 7884, 7886, 7888, 7890, 7892, 7894, 7896, 7898, 7900, 7902, 7904, 7906
sConvert = sConvert & "O"
Case 249, 250, 361, 432, 7909, 7911, 7913, 7915, 7917, 7919, 7921
sConvert = sConvert & "u"
Case 217, 218, 360, 431, 7908, 7910, 7912, 7914, 7916, 7918, 7920
sConvert = sConvert & "U"
Case 253, 7923, 7925, 7927, 7929
sConvert = sConvert & "y"
Case 221, 7922, 7924, 7926, 7928
sConvert = sConvert & "Y"
Case Else
sConvert = sConvert & sChar
End Select
Next
ConvertToUnSign = sConvert
End FunctionPrivate Sub Worksheet_Deactivate()
On Error GoTo ext
Me.Name = ConvertToUnSign([b1].Text)
ext:
End Sub#1/ Hiện tại em không dùng Array nhiều, chỉ dùng Đệ quy nhiều. Vấn đề phình String em chưa nghiên cứu nhưng em sẽ thử set lại "" (Em có đọc đâu đó nên set vbNullString tốt hơn)
Option Explicit
Public wb As Workbook
Public wb_App As Workbook
Public ws As Worksheet
Public ws_Login As Worksheet, ws_MemData As Worksheet, ws_TimeSheet As Worksheet
Public ws_Record As Worksheet, ws_OffData As Worksheet, ws_Confirm As Worksheet, ws_DateTime As Worksheet, ws_Manager As Worksheet
Public rng As Range
'Declare ranges in the APP file
Public btn_InfoLogin As Range, btn_Contact As Range, btn_BackInfo As Range, btn_ForgetPW As Range, btn_Login As Range, btn_AppInfo As Range, frm_UserID As Range, frm_UserPW As Range
'Declare ranges in the DATA file
Public rng_UserID As Range, rng_UserName As Range, rng_PubKey As Range, rng_Manager As Range, rng_DataTittle As Range
Public rng_EnDays As Range, rng_EnHours As Range, rng_EnMins As Range
Public rng_OutDays As Range, rng_OutHours As Range, rng_OutMins As Range
Public rng_FromDate As Range, rng_ToDate As Range, rng_FromTime As Range, rng_ToTime As Range, rng_Notes As Range
'Declare object
Public OutApp As Object, OutMail As Object
Public icnt As Long, jcnt As Long, lng_lastRow As Long
'Public int_UsedDays As Integer, int_UsedHours As Integer, int_UsedMins As Integer
'Public int_EnDOff As Integer, int_EnHOff As Integer, int_EnNOff As Integer, int_AsEnNOff As Integer
Public Cancel As Boolean
Public Const strPATH As String = "\\A\B\"
Public Const strDATA As String = "offworkDATA.xlsm"
Public Const strAPP As String = "offworkAPP.xlsm"
Public Const strPubPW As String = "XYZ"
Public answer As StringVấn đề của em nằm ở chỗ cái file APP của em không hoàn toàn được đóng trong VBE, như bình luận của anh Werner Mittrup.
Cám ơn Anh nhiều
Bạn xem lại 2 chỗ ghi chú trong code:
Private Sub CommandButton1_Click()
Dim Dic As Object, sArr(), dArr(), I As Long, Tem As String
Set Dic = CreateObject("Scripting.Dictionary")
sArr = Range([C8], [C8].End(xlDown)).Resize(, 6).Value2
ReDim dArr(1 To UBound(sArr, 1), 1 To 1)
For I = 1 To UBound(sArr, 1)
Tem = sArr(I, 1) & sArr(I, 3) '<-------Chỗ này---------'
If Not Dic.Exists(Tem) Then
Dic.Add Tem, sArr(I, 6)
Else
Dic.Item(Tem) = Dic.Item(Tem) + sArr(I, 6)
End If
Next I
For I = 1 To UBound(sArr, 1)
dArr(I, 1) = Dic.Item(sArr(I, 1) & sArr(I, 3)) '<------và chỗ này-------------'
Next I
[I8].Resize(I - 1) = dArr
Set Dic = Nothing
End SubEm đã giải quyết được vấn đề của mình. Lỗi ở 1 dòng code khiến nó không hoạt động được như ý.
Sub XoaSoLieu()
Sheets("HD").Select
Range("B11:B14", "F3", "A3", "B19", "E29", "C31").Select
Selection.ClearContents
Range("F1").Select
End Sub
Trong ổ D, tạo 1 Folder mới với tên là DIEN_2018.
Sub ThuXuatFile_Moi()
Dim Path As String
Dim filename As String
Dim FileMoi
Path = "D:\DIEN_2018\"
filename = Sheet1.Range("K4") 'gõ tên File càn luu vào K4
Set FileMoi = Workbooks.Add
Sheet1.Copy Before:=FileMoi.Sheets(1)
ActiveWorkbook.SaveAs filename:=Path & filename & ".xls", FileFormat:=xlNormal
ActiveWindow.Close
End Subem cần 2 file đặt chung 1 folder, và không cố định đường dẫn (như bác đang là D:\Dien2018...) để có thể linh hoạt hơn trong sử dụng (share cho người khác, đặt trong folder dự án khác nhau...)
Tại K4 của sheet Data_Cable bạn gõ tên File cần lưu, khi lưu thì nó hiện hộp thoại bạn muốn lưu chỗ nào là tùy bạn.
Sub Luu_TuyChon()
Dim TenFile As String
Dim FileMoi As Object
TenFile = Sheet1.Range("K4")
Set FileMoi = Workbooks.Add
Sheet1.Copy Before:=FileMoi.Sheets(1)
Application.Dialogs(xlDialogSaveAs).Show TenFile
ActiveWindow.Close
End SubThisWorkbook.Worksheets("Data_Cable")Trong code trên:
'ThisWorkbook.Sheets("Data_Cable").Copy Before:=FileMoi.Sheets(1)
Sheet1.Copy Before:=FileMoi.Sheets(1)
Vấn đề không đơn giản như đã trình bầy ở chủ đề này - vài dòng code tách sheet sang tập tin mới..
Bác nhắc em mới để ý đến, để em sửa lại phần Name. Nếu phương án sửa tham chiếu về tập tin đóng chạy được thì em sẽ chuyển phần Name (phục vụ cho Data Validation) về chung file bảng tính chọn, file Data chỉ để thông số của dây cáp. Em cũng muốn bảng tính nó hoàn thiện dần, tốt hơn. Em cũng không kinh nghiệm nhiều về code (thời sinh viên em cũng mày mò 1 ít Matlab) nên mong các bác chỉ bảo thêm.
