Chuyên mục xử lý, gỡ rối code VBA (1 người xem)

[ndu96081631]

Topic Những câu hỏi về code, xin giải thích các code... đã quá dài nên mình đóng nó lại và mở topic khác
Tất cả những bài viết liên quan đến việc nhờ giải thích, xử lý và gỡ rối code VBA, các bạn vui lòng đăng tại đây!
Cảm ơn

 

[be_09]

hi bác @be09

Em có mò sửa lại code file trên để tách rời 2 file: bảng tính - data.
Nhưng gặp vấn đề ở đây là file data file luôn mở khi chạy bảng tính.
Em có đọc bài này http://www.giaiphapexcel.com/vbb/sh...-liệu-từ-1-file-đang-đóng&p=260991#post260991
Nhưng không rõ áp dụng trong trường hợp của em thì nên sử dụng như thế nào?
Bác có thể hướng 1 chút giúp em được không?

Tôi thấy bạn đưa cái File này: Ladder size Calculation v1, khác với sheet gốc mà không diễn giải nên chẳng hiểu gì ráo.
Còn đưa cái Link lấy dữ liệu File đang đóng, cả 2 vấn đề thấy không có liên quan gì với nhau nên cũng chẳng hiểu gì luôn.

Bạn nên mở Topic mới có ví dụ thực tế và giải thích cái cần rỏ ràng hơn, để các thành viên có hiểu mới giúp được tập trung hơn.

 

[bigbabol89]

Em chào các anh, em mong các anh giúp em vấn đề này với ạ :
Em cần gửi email phiếu lương cho khoảng 500 anh em. Em có sưu tầm được 1 code về tự động gửi email trong excel, tuy nhiên code đó gửi mail theo từng sheet riêng rẽ một. Mà file dữ liệu gửi của em nó nằm trong 1 sheet, và dữ liệu của 1 người đều đồng nhất mỗi người 31 dòng. Em muốn gửi thông tin từng người tới từng địa chỉ email của người đó. ( Em dùng OUTLOOK ạ )
Em mong các anh giúp em ạ

Sub Send_Files()
'Working in 2000-2007
Dim OutApp As Object
Dim OutMail As Object
Dim sh As Worksheet
Dim cell As Range, FileCell As Range, rng As Range
With Application
    .EnableEvents = False
    .ScreenUpdating = False
End With
Set sh = Sheets("Sheet1")
Set OutApp = CreateObject("Outlook.Application")
OutApp.Session.Logon
For Each cell In sh.Columns("B").Cells.SpecialCells(xlCellTypeConstants)
    'Enter the file names in the C:Z column in each row
    Set rng = sh.Cells(cell.Row, 1).Range("C1:Z1")
    If cell.Value Like "?*@?*.?*" And Application.WorksheetFunction.CountA(rng) > 0 Then
        Set OutMail = OutApp.CreateItem(0)
        With OutMail
            .To = cell.Value
            .Subject = "Testfile"
            .Body = "Hi " & cell.Offset(0, -1).Value
            For Each FileCell In rng.SpecialCells(xlCellTypeConstants)
                If Trim(FileCell) <> "" Then
                    If Dir(FileCell.Value) <> "" Then
                        .Attachments.Add FileCell.Value
                    End If
                End If
            Next FileCell
            .Send
            'Or use Display
        End With
        Set OutMail = Nothing
    End If
Next cell
Set OutApp = Nothing
With Application
    .EnableEvents = True
    .ScreenUpdating = True
End With
End Sub

 

[Kiều Mạnh]

Trong File mình đang sử dụng có nhiều sub nó giống nhau ... giờ mình muốn viết lại nó thành một cái Hàm bao quát nhất có thể sử dụng cho nhiều trường hợp khác nhau ... mà đang lúng túng xử lý For next xong nối các chuỗi lại ... Vì vậy Úp bài nhờ các bạn trợ giúp xử lý dùm

1/ Code mẫu nếu sử dụng 1 Vòng For thì Ok ... nhưng khi Mình mở rộng Mảng Arr() thì phải điều chỉnh lại code mất công quá
chuỗi Qry sau mỗi lần For tại F1

Private Sub Test_Mau()
    Dim Arr(), i As Long, x1, x2
    Dim Qry As String
    Arr = Range("A4:B100").Value
    For i = 1 To UBound(Arr, 1)
        If Arr(i, 1) <> "" Then
            x1 = GetValue(Arr(i, 1))
            x2 = GetValue(Arr(i, 2))
            MsgBox x1
            Qry = "INSERT INTO Manh2 VALUES(" _
                & i & ", " & x1 & ", " & x2 & ")"
            Range("F1").Value = Qry
        End If
    Next
End Sub

2/ Code sau Mình muốn cho nó vào Mảng Động .... có nghĩa mình muốn thêm hay bớt cột thì duyệt For ở dưới nó tự lấy theo và nối chuỗi đó vào Qry giống như sub Trên ... Chuỗi nối theo thứ tự tại F2

Private Sub Test_NhoXuLy()
    Dim Arr(), i As Long, j As Long, n
    Dim Res(), x1, x2
    Dim Qry As String
    Arr = Range("E4:I100").Value                            ''mang nay co the then nhieu cot hay giam bot
    For i = 1 To UBound(Arr, 1)
        If Arr(i, 1) <> "" Then
            For j = 1 To UBound(Arr, 2)                     ''duyet For i, J lam sao cho no lay tuong ung voi so cot cua mang
                'x1 = GetValue(Arr(i, 1))
                'x2 = GetValue(Arr(i, 2))                   ''Bo het kieu nay
                'MsgBox " OK"                               ''Gan mang Arr(i,j) lam sao vao Qry noi cac chuoi lai voi nhau nhu sub Test_Mau
                Qry = "INSERT INTO Manh2 VALUES(" _
                    & i & ", " & x1 & ", " & x2 & ")"
                Range("F2").Value = Qry                     ''Cac chuoi sau khi noi lai trong mang
            Next
        End If
    Next
End Sub

Mình đang lúng túng xử lý ở Mục 2 làm sao duyệt For mà bỏ hết x1,x2,... xn đi mà nó tự nối chuỗi vào Qry như mục 1
Xin cản ơn

 

[VetMini]

Qry = " INSERT INTO Manh2 VALUES( " & i
For j = 1 To UBound(Arr, 2) 'duyet For i, J lam sao cho no lay tuong ung voi so cot cua mang
Qry = Qry & ", " & GetValue(Arr(i, j))
Next
Qry = Qry & " )"
Range("F2").Value = Qry 'Cac chuoi sau khi noi lai trong mang

1. đây là giả sử câu insert của bạn khong cần tên trường (số trường insert tương đương với mặc định)

2. cũng giả sử rằng cái hàm GetValue của bạn nó tự biết thêm dấu nháy cho các dữ liệu chuỗi.

 

[Kiều Mạnh]

Qry = " INSERT INTO Manh2 VALUES( " & i
For j = 1 To UBound(Arr, 2) 'duyet For i, J lam sao cho no lay tuong ung voi so cot cua mang
Qry = Qry & ", " & GetValue(Arr(i, j))
Next
Qry = Qry & " )"
Range("F2").Value = Qry 'Cac chuoi sau khi noi lai trong mang

1. đây là giả sử câu insert của bạn khong cần tên trường (số trường insert tương đương với mặc định)

2. cũng giả sử rằng cái hàm GetValue của bạn nó tự biết thêm dấu nháy cho các dữ liệu chuỗi.

Mình đang suy nghĩ là nếu ta không sử dụng phương thức insert ... mà ta sử dụng phương thức sau

Rst.Open tableName, MyString, adOpenStatic, adLockOptimistic
For i = 1 To UBound(Res, 1)  
        Rst.AddNew
        For j = 1 To Rst.Fields.Count - 1
            Rst.Fields(j) = Res(i, j)
        Next j  
Next i
Rst.Update

Thì giữa 2 cái đó áp dụng cho trường hợp nào sẻ yêu việt hơn vv...
Tại vì code két mình tự học và bắt trước người ta làm sao mình làm vậy nếu chạy thấy lỗi thì tìm cách sửa nên ko hiểu hết được bản chất thật sự của 2 cách trên
Mong bạn chỉ thêm ... Xin cảm ơn

 

[alias1313]

sub down()
 Dim ChromeLocation  As String
Linkurl   ' là link down trực tiếp
 ChromeLocation = "C:\Program Files (x86)\Google\Chrome\Application\chrome.exe"
  Shell (ChromeLocation & " -url & Linkurl )
End sub

Khi chạy code trên đến đoạn gọi Firefox thì cửa sổ trình duyệt bung ra, rất bất tiện, vì em không cần thao tác tay trên trình duyệt nên
Em muốn ẩn Firefox khi chạy code ( giống như IE mình có lệnh : IE.visble = false), Mong các anh giúp đỡ!

 

[VetMini]

Insert từng record là cách căn bản của chạy trực tiếp trên CSDL
Dùng recordset là dùng giao diện gián tiếp qua code.
Đã viết code thì dùng giao diện tiện hơn.

 

[tinhyeulunglinh123]

Có ai giúp giùm em cái này không ạ. file excel của em khi chạy marco vba này luôn mặc định là trình duyệt IE. em muốn chuyển sang mở bằng Chrome hoặc Firefox nhưng em k biết về code. đoạn code trong file module như sau:



Option Explicit
Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Dim URL As String
Dim BVISIBLE As Boolean
Dim DELAY As Long
Dim NUM As String
Dim SHUTD As Integer

Dim SES_col As Integer
Const TYPE_CLICK As String = "CLICK"
Const TYPE_SET As String = "SET"
Const TYPE_URL As String = "URL"
Const TYPE_GET As String = "GETDATA"
Const TYPE_GETLINK As String = "GETLINK"
Const TYPE_SEND As String = "SEND"
Const TYPE_SEARCH1 As String = "SEARCHLINK"
Const TYPE_FORCE As String = "FORCE" 'right type

Sub reg_web()
Dim sh As Variant
Dim i, j As Long
Dim r1, r2, r3 As Variant
Dim rowfrom, colfrom As Long

Set sh = ThisWorkbook.ActiveSheet

If Not init(sh) Then
Exit Sub
End If

colfrom = 0
NUM = 0
ReDim r1(NUM)
ReDim r2(NUM)
ReDim r3(NUM)
For j = 1 To 65535
If sh.Rows(2).Cells(j).value = "" And sh.Rows(2).Cells(j + 1).value = "" _
And sh.Rows(2).Cells(j + 2).value = "" Then
Exit For
End If

NUM = NUM + 1
ReDim Preserve r1(1 To NUM)
ReDim Preserve r2(1 To NUM)
ReDim Preserve r3(1 To NUM)
r1(j) = Trim(CStr(sh.Rows(2).Cells(j).value))
r2(j) = Trim(CStr(sh.Rows(3).Cells(j).value))
If colfrom = 0 And _
StrComp(Left(sh.Rows(2).Cells(j).value, Len(TYPE_SET)), _
TYPE_SET, vbTextCompare) = 0 Then 'col for available of data,
colfrom = j
End If

Next j

rowfrom = Application.Max(sh.Cells(1, SES_col), 4) '4 is start

For i = rowfrom To 65535
sh.Cells(1, SES_col) = i
If (sh.Cells(i, colfrom) = "" _
And sh.Cells(i + 1, colfrom) = "" _
And sh.Cells(i + 2, colfrom) = "") Then
Exit For
ThisWorkbook.Save
End If
If i Mod 10 = 0 Then
ThisWorkbook.Save
End If

If sh.Cells(i, colfrom) <> "" Then
For j = 1 To NUM
r3(j) = Trim(CStr(sh.Rows(i).Cells(j).value))
Next j
sh.Cells(i, NUM + 1).value = "K" & reg(URL, r1, r2, r3, NUM)
End If

'write output and all infor again to excel
For j = 1 To NUM
sh.Rows(i).Cells(j).value = Format(r3(j))
sh.Rows(i).Cells(j).Font.Color = RGB(0, 0, 0)
If Mid(sh.Cells(i, NUM + 1).value, j, 1) = 1 Then
Else
sh.Rows(i).Cells(j).Font.Color = RGB(255, 0, 0)
End If

Next j

Next i
ThisWorkbook.Save

If SHUTD > 0 Then
Shell ("cmd /c shutdown -s -f -t 1")
End If

End Sub

Private Function reg(ByVal lurl As String, ByRef setref As Variant, ByRef setxpath As Variant, ByRef setvalue As Variant, ByVal n As Integer) As String
Dim htmldoc, oIE1Doc As HTMLDocument
Dim MyBrowser, oIE1 As InternetExplorer
Dim MyHTML_Element, oIE1Element As IHTMLElement
Dim i As Long
Dim ret, a As String
Dim out As String
Dim b As String

Application.DisplayAlerts = False
wait_time (3)

b = ShellRun("taskkill /f /im iexplore.exe")
b = ShellRun("taskkill /f /im MicrosoftEdge.exe")
b = ShellRun("taskkill /f /im ielowutil.exe")

Set MyBrowser = New InternetExplorer
MyBrowser.Visible = BVISIBLE

ret = String(n, "0")
For i = 1 To n
If setref(i) <> "" Then a = "0" Else: a = "1"
If StrComp(Left(setref(i), Len(TYPE_URL)), TYPE_URL, vbTextCompare) = 0 Then
lurl = URL
If StrComp(Left(setvalue(i), 4), "html", vbTextCompare) = 0 _
And setvalue(i) <> lurl Then 'URL ,reload page
lurl = setref(i)

End If

MyBrowser.navigate lurl
Loading MyBrowser, 1
Set htmldoc = MyBrowser.document
a = "1"
End If

If StrComp(Left(setref(i), Len(TYPE_CLICK)), TYPE_CLICK, vbTextCompare) = 0 Then 'if a button -> click
If ClickXpath(htmldoc, setxpath(i)) Then
Loading MyBrowser, 3
a = "1"
End If
End If

If StrComp(Left(setref(i), Len(TYPE_SEND)), TYPE_SEND, vbTextCompare) = 0 Then 'if a send key
If SendKeyhtml(MyBrowser, BVISIBLE, htmldoc, setxpath(i)) Then
Loading MyBrowser, 3
a = "1"
End If
End If

If StrComp(Left(setref(i), Len(TYPE_SET)), TYPE_SET, vbTextCompare) = 0 _
And setvalue(i) <> "" And setxpath(i) <> "" Then 'Set Object
If InputValueXpath(htmldoc, setxpath(i), setvalue(i)) Then
Loading MyBrowser, 1
a = "1"
Else
End If
End If

'output
If StrComp(Left(setref(i), Len(TYPE_GET)), TYPE_GET, vbTextCompare) = 0 _
And setxpath(i) <> "" Then 'Get Object
out = ""
If GetValueXpath(htmldoc, setxpath(i), out) Then
Loading MyBrowser, 1
a = "1"
Else
End If
setvalue(i) = out
End If

If StrComp(Left(setref(i), Len(TYPE_GETLINK)), TYPE_GETLINK, vbTextCompare) = 0 _
And setxpath(i) <> "" Then 'Get Object
out = ""
If GetLinkXpath(htmldoc, setxpath(i), out) Then
Loading MyBrowser, 1
a = "1"
Else
End If
setvalue(i) = out
End If

If StrComp(Left(setref(i), Len(TYPE_SEARCH1)), TYPE_SEARCH1, vbTextCompare) = 0 _
And setxpath(i) <> "" Then 'Get Search Object
out = ""
If SearchLink(htmldoc, setxpath(i), out) Then
Loading MyBrowser, 0
a = "1"
Else
End If
setvalue(i) = out
End If

'Check to continous or not
ret = Left(ret, i - 1) & a & Mid(ret, i + 1)
If StrComp(Right(setref(i), Len(TYPE_FORCE)), TYPE_FORCE, vbTextCompare) = 0 _
Or a <> "0" Then
Else
Exit For
End If

Next i

reg = ret
Set htmldoc = Nothing
MyBrowser.Stop
MyBrowser.Quit
Set MyBrowser = Nothing

Delete_IE_Cache
reg = ret
End Function


Private Function init(ByVal sh As Variant) As Boolean
Dim key As String

init = True
URL = sh.Cells(1, Application.Match("URL:", sh.Range("A1:AA1"), False) + 1)
BVISIBLE = False
If StrComp(sh.Cells(1, Application.Match("Visible:", sh.Range("A1:AA1"), False) + 1), "1", vbTextCompare) = 0 Then
BVISIBLE = True
End If
DELAY = Int(sh.Cells(1, Application.Match("DELAY:", sh.Range("A1:AA1"), False) + 1))

SHUTD = Int(sh.Cells(1, Application.Match("SHUTDOWN:", sh.Range("A1:AA1"), False) + 1))

SES_col = Application.Match("SESSION:", sh.Range("A1:AA1"), False) + 1

'Genuine
key = sh.Cells(1, Application.Match("ACTIVE:", sh.Range("A1:AA1"), False) + 1)
key = Main_Key_Check(sh, key)
sh.Cells(1, Application.Match("ACTIVE:", sh.Range("A1:AA1"), False) + 1) = key

'About:
sh.Cells(1, 1) = "DonateNEO:"
sh.Cells(1, Application.Match("DonateNEO:", sh.Range("A1:AA1"), False) + 1) = "AcdsTrQtcUu1hXqpdW5bwvgZSSpeeT12r8"

End Function
'<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>'
Private Sub Delete_IE_Cache()
Dim a As String
'using get output to wait until cmd end

a = ShellRun("taskkill /f /im iexplore.exe")
a = ShellRun("taskkill /f /im MicrosoftEdge.exe")
a = ShellRun("taskkill /f /im ielowutil.exe")
a = ShellRun("RunDll32.exe InetCpl.Cpl, ClearMyTracksByProcess 255")
a = ShellRun("RunDll32.exe InetCpl.Cpl, ClearMyTracksByProcess 32")
a = ShellRun("RunDll32.exe InetCpl.cpl, ClearMyTracksByProcess 4351")

'MicrosoftEdge.exe
a = ShellRun("cmd /c del /s /f /q C:\Users\Administrator\AppData\Local\Microsoft\Windows\INetCache\*")
a = ShellRun("cmd /c del /s /f /q C:\Users\Administrator\AppData\Local\Microsoft\Windows\INetCookies\*")
a = ShellRun("cmd /c del /s /f /q C:\Users\Administrator\AppData\Local\Microsoft\Windows\WebCache\*")

'C:\Users\Administrator\AppData\Local\Microsoft\Windows\INetCookies

wait_time (1)
End Sub
Private Function ShellRun(sCmd As String) As String

'Run a shell command, returning the output as a string

Dim oShell As Object
Set oShell = CreateObject("WScript.Shell")

'run command
Dim oExec As Object
Dim oOutput As Object
Set oExec = oShell.Exec(sCmd)
Set oOutput = oExec.StdOut

'handle the results as they are written to and read from the StdOut object
Dim s As String
Dim sLine As String
While Not oOutput.AtEndOfStream
sLine = oOutput.ReadLine
If sLine <> "" Then s = s & sLine & vbCrLf
Wend

ShellRun = s

End Function
Public Sub Loading(ByVal MyBrowser As InternetExplorer, Optional waitt As Integer = 0)
Const READYSTATE_COMPLETE As Integer = 4
Do
DoEvents
Loop Until MyBrowser.readyState = READYSTATE_COMPLETE And MyBrowser.Busy = False 'And MyBrowser.statusText = "Done" 'And MyBrowser.document.readyState = "complete"
wait_time (waitt + DELAY)
End Sub

Private Sub wait_time(ByVal a As Integer)
Dim time1, time2

If a > 59 Then
a = 59
End If

time1 = Now
time2 = Now + TimeValue("0:00:" & Format(a, "00"))
Do Until time1 >= time2
DoEvents
time1 = Now()
Loop

End Sub

 

[embevinhphuc]

Kính chào các thầy các anh chị, em có xem được cái code của thầy dhn46 và mở rộng nó,
code đầu tiên là cộng từng phần tử tương ứng của 2 hàng bất kỳ trong mảng (được 1 hàng kết quả), rồi đếm ngược từ phần tử 200 của mảng xem hàng kết quả nào >0 và dài nhất, cuối cùng là chỉ ra các hàng thỏa mãn.

Vấn đề của em bây giờ là khi em mở rộng từ tìm 2 hàng thành 3,4,5...10 hàng như vậy thì code chạy nặng quá, em treo máy cả ngày chưa thấy xong. nguyên nhân em nghĩ là vì là em dùng nhiều vòng lặp for lồng nhau. em xin hỏi các thầy, các anh chị là có cách nào khác khả thi không ạ, làm ơn chỉ dạy em ạ. em cảm ơn nhiều.

 

[truongvu317]

Kính chào các thầy các anh chị, em có xem được cái code của thầy dhn46 và mở rộng nó,
code đầu tiên là cộng từng phần tử tương ứng của 2 hàng bất kỳ trong mảng (được 1 hàng kết quả), rồi đếm ngược từ phần tử 200 của mảng xem hàng kết quả nào >0 và dài nhất, cuối cùng là chỉ ra các hàng thỏa mãn.

Vấn đề của em bây giờ là khi em mở rộng từ tìm 2 hàng thành 3,4,5...10 hàng như vậy thì code chạy nặng quá, em treo máy cả ngày chưa thấy xong. nguyên nhân em nghĩ là vì là em dùng nhiều vòng lặp for lồng nhau. em xin hỏi các thầy, các anh chị là có cách nào khác khả thi không ạ, làm ơn chỉ dạy em ạ. em cảm ơn nhiều.

Nói rõ mục đích cho nhanh, viết lại cho nhanh. NÓi dài km mà chả rõ là đang nói cái gì sứt.

 

[embevinhphuc]

Nói rõ mục đích cho nhanh, viết lại cho nhanh. NÓi dài km mà chả rõ là đang nói cái gì sứt.

Dạ
1. Cộng giá trị phần tử tương ứng của 10 hàng bất kỳ trong mảng= hàng kết quả
2. Đếm ngược từ cột 200 trở lại, tìm hàng kết quả có phần tử lớn hơn 0 dài nhất
3. Chỉ ra các hàng thỏa mãn

 

[truongvu317]

"Tại anh không hiểu hay bởi dò trời.
Trời đày hai đưa xa nhau, đành lòng ôm tuyết lạnh mùa đông"
Nó là cái gì, nó nằm ở đâu, dữ liệu đầu vào lấy ở đâu, xuát kết quả vào đâu?
Tui người trần mắt hột có biết gì đâu về file của bạn.

 

[embevinhphuc]

"Tại anh không hiểu hay bởi dò trời.
Trời đày hai đưa xa nhau, đành lòng ôm tuyết lạnh mùa đông"
Nó là cái gì, nó nằm ở đâu, dữ liệu đầu vào lấy ở đâu, xuát kết quả vào đâu?
Tui người trần mắt hột có biết gì đâu về file của bạn.

Dữ liệu là mảng Arr = [E11:GV1080]
Trả kết quả ra mảng mới bắt đầu từ [GX11] ( [GX11].Resize(UBound(sArr, 1), 2) = sArr)
Bài toán này nếu tìm 2,3 hàng thì chạy được (Nút Team2,3) nhưng nếu tìm 10 hàng thì chưa chạy được nên em muốn hỏi có thuật toán nào khác hợp lý hơn không ạ.

 

[truongvu317]

Dữ liệu là mảng Arr = [E11:GV1080]
Trả kết quả ra mảng mới bắt đầu từ [GX11] ( [GX11].Resize(UBound(sArr, 1), 2) = sArr)
Bài toán này nếu tìm 2,3 hàng thì chạy được (Nút Team2,3) nhưng nếu tìm 10 hàng thì chưa chạy được nên em muốn hỏi có thuật toán nào khác hợp lý hơn không ạ.

Chỉ đoán là bạn đang cố liệt kê một nhóm các hàng thỏa mãn một điều kiện nào đó. Thử dùng đệ quy xem có được không?

 

[tueyennhi]

Em có đoạn code sau:

Private Sub Workbook_open()
Dim clls As Range
Dim Bophan As String
Dim Noidung As String
Dim d As Date
Bophan = Sheets("Sign").Range("AH2") & Sheets("Sign").Range("E8")
d = FormatDateTime(Date, vbLongDate)
Noidung = Sheets("Sign").Range("AH3") & d
For Each clls In Range("G8:H" & Range("B" & Rows.Count).End(xlUp).Row)
    clls = Val(clls)
    clls.NumberFormat = "d/m/yyyy"
Next clls
Range("A2").Value = Noidung
Range("A3").Value = Bophan
Rows("8:5000").Hidden = False
Rows(Range("B" & Rows.Count).End(xlUp).Row + 1 & ":5000").Hidden = True
End Sub

Cho em hỏi đoạn code d = FormatDateTime(Date, vbLongDate)
Em dùng để format theo giờ hệ thống nhưng các máy khác chưa chắc đặt giờ hệ thống giống máy em. Vậy sửa code thế nào để cho phần định dạng theo đúng giá trị là
tháng/năm.
Ngoài ra anh chị xem code trên có thể tối giản cho chạy nhanh hết mức có thể không thì chỉ cho em nhé.
Em cảm ơn!

 

[truongvu317]

d = FormatDateTime(Date, vbLongDate)
Noidung = Sheets("Sign").Range("AH3") & d

Vô lý nhỉ, biến d là date, d = FormatDateTime(Date, vbLongDate) chẳng có một chút tác dụng nào, thà viết d=date cho nó nhanh. dùng hàm format xem

 

[tueyennhi]

Vô lý nhỉ, biến d là date, d = FormatDateTime(Date, vbLongDate) chẳng có một chút tác dụng nào, thà viết d=date cho nó nhanh. dùng hàm format xem

Mình sửa thành như vậy đã theo ý
Option Explicit
Private Sub Workbook_open()
Dim clls As Range
Dim Bophan As String
Dim Noidung As String
Dim d As Date
Bophan = Sheets("Sign").Range("AH2") & Sheets("Sign").Range("E8")
Noidung = Sheets("Sign").Range("AH3") & Format(Date, "mm-yyyy")
For Each clls In Range("G8:H" & Range("B" & Rows.Count).End(xlUp).Row)
clls = Val(clls)
clls.NumberFormat = "d/m/yyyy"
Next clls
Range("A2").Value = Noidung
Range("A3").Value = Bophan
Rows("8:5000").Hidden = False
Rows(Range("B" & Rows.Count).End(xlUp).Row + 1 & ":5000").Hidden = True
End Sub

Nhưng tốc độ còn chậm không biết có hướng xử lý mảng nào hiệu quả hơn là duyệt từng Cell không nhỉ mọi người?

 

[truongvu317]

Mình sửa thành như vậy đã theo ý
Option Explicit
Private Sub Workbook_open()
Dim clls As Range
Dim Bophan As String
Dim Noidung As String
Dim d As Date
Bophan = Sheets("Sign").Range("AH2") & Sheets("Sign").Range("E8")
Noidung = Sheets("Sign").Range("AH3") & Format(Date, "mm-yyyy")
For Each clls In Range("G8:H" & Range("B" & Rows.Count).End(xlUp).Row)
clls = Val(clls)
clls.NumberFormat = "d/m/yyyy"
Next clls
Range("A2").Value = Noidung
Range("A3").Value = Bophan
Rows("8:5000").Hidden = False
Rows(Range("B" & Rows.Count).End(xlUp).Row + 1 & ":5000").Hidden = True
End Sub

Nhưng tốc độ còn chậm không biết có hướng xử lý mảng nào hiệu quả hơn là duyệt từng Cell không nhỉ mọi người?

tính xem cái vùng dữ liệu đó là gì, rồi rng.value=rng.value
rng.numberformat=.....

 

[tueyennhi]

Em có một đối tượng tên là Pic1 tại sheet 2. Làm thế nào để dùng vba copy nó sang sheet 1?

 

[thang605555]

Nhờ mọi người giúp code này:

Function TT(cell As Range)
TT = Evaluate("=" & cell)
End Function

Công dụng: trong cell A1 có nội dung 2*2 thì hàm trong cell B1 là TT(A1) sẽ có giá trị 4.
Tuy nhiên nếu cell A1 có giá trị là 2.1 thì hàm trong cell B1 là TT(A1) sẽ có giá trị #VALUE! mà không phải là 2.1

Vì vậy em nhờ mọi người giúp code này để hiện ra giá trị 2.1

 

[PacificPR]

Nhờ mọi người giúp code này:

Function TT(cell As Range)
TT = Evaluate("=" & cell)
End Function

Công dụng: trong cell A1 có nội dung 2*2 thì hàm trong cell B1 là TT(A1) sẽ có giá trị 4.
Tuy nhiên nếu cell A1 có giá trị là 2.1 thì hàm trong cell B1 là TT(A1) sẽ có giá trị #VALUE! mà không phải là 2.1

Vì vậy em nhờ mọi người giúp code này để hiện ra giá trị 2.1

Bạn thử như thế này xem có được không

Function TT(Str As String)
    Str = Replace(Str, ",", ".")
    TT = Evaluate("=" & Str)
End Function

 

[ndu96081631]

Bạn thử như thế này xem có được không

Function TT(Str As String)
    Str = Replace(Str, ",", ".")
    TT = Evaluate("=" & Str)
End Function

Tôi nghĩ vầy mới đúng:

Function TT(ByVal Text As String)
  Dim tmp
  TT = Text
  tmp = Evaluate(Text)
  If TypeName(tmp) <> "Error" Then TT = tmp
End Function

Tức nếu không tính toán được thì để nguyên. Tự ý thay đổi dấu chấm dấu phẩy là điều không nên, bởi ai mà biết được máy tính nào quy định thế nào về dấu thập phân và phân cách ngàn

 

[befaint]

Tự ý thay đổi dấu chấm dấu phẩy là điều không nên, bởi ai mà biết được máy tính nào quy định thế nào về dấu thập phân và phân cách ngàn

Em tưởng trong VBA thì vẫn luôn là chấm chứ anh.
(Không tính trường hợp chuỗi một số gồm cả chấm và phẩy).

 

[ndu96081631]

Em tưởng trong VBA thì vẫn luôn là chấm chứ anh.
(Không tính trường hợp chuỗi một số gồm cả chấm và phẩy).

Nhưng người ta nói vầy:

Tuy nhiên nếu cell A1 có giá trị là 2.1 thì hàm trong cell B1 là TT(A1) sẽ có giá trị #VALUE! mà không phải là 2.1

Vì vậy em nhờ mọi người giúp code này để hiện ra giá trị 2.1

Vậy chuyện này là sao?

 

[truongvu317]

Em tưởng trong VBA thì vẫn luôn là chấm chứ anh.

VBa, hay chính xác hơn là ngôn ngữ VB thì nó tính theo dấu chấm. Còn cái Evaluate nó không phải là vba, nó là thứ người ta viết ra dựa trên vb. Tóm lại là nó tính theo thiết lập của Excel. Tóm lại là anh kiểm tra lại hộ em cái.

 

[truongvu317]

Excel có cái phần name với hàm Evaluate cũng có thể dùng thay trong trường hợp này, không phải co với cốt làm gì.

 

[befaint]

Nhưng người ta nói vầy:

Vậy chuyện này là sao?

Em thay đổi thiết lập dấu phân cách trong Control rồi thử hàm ở bài #1540 thì 2 trường hợp: Dấu phân cách phần thập phân là dấu chấm/ Hoặc dấu phẩy thì đều cho kết quả đúng.

Em cũng nhớ mang máng có một anh nói cái này rồi, chờ anh đó vào nhắc lại (có thể em nhớ nhầm).

 

[befaint]

VBa, hay chính xác hơn là ngôn ngữ VB thì nó tính theo dấu chấm. Còn cái Evaluate nó không phải là vba, nó là thứ người ta viết ra dựa trên vb. Tóm lại là nó tính theo thiết lập của Excel. Tóm lại là anh kiểm tra lại hộ em cái.

Về lý thuyết thì mình chịu rồi, không có kiến thức đó.

 

[truongvu317]

Em thay đổi thiết lập dấu phân cách trong Control rồi thử hàm ở bài #1540 thì 2 trường hợp: Dấu phân cách phần thập phân là dấu chấm/ Hoặc dấu phẩy thì đều cho kết quả đúng.

Em cũng nhớ mang máng có một anh nói cái này rồi, chờ anh đó vào nhắc lại (có thể em nhớ nhầm).

Lạ nghen, máy của người ta bị si đa. si đa mà vẫn xông phá đi viết code. anh nhập trực tiếp trong vba xem.

 

[befaint]

nhập trực tiếp trong vba xem

Không rõ nhập trực tiếp như này phải không? (Thiết lập control, dấu phân cách phần thập phân là dấu phẩy).

 

[VetMini]

...
Em cũng nhớ mang máng có một anh nói cái này rồi, chờ anh đó vào nhắc lại (có thể em nhớ nhầm).

Có phải bạn nói cái vụ xét MID(3/2, 2,1) để biết máy hiện tại dùng hệ thống nào?

(tôi chỉ nhắc thôi chứ tôi không phải là cái "anh" kia)

 

[befaint]

Có phải bạn nói cái vụ xét MID(3/2, 2,1) để biết máy hiện tại dùng hệ thống nào?

Em chỉ nhớ láng máng được nội dung: Trong VBA thì luôn nhận dấu chấm là dấu phân cách phần thập phân, ngoài bảng tính thì cần để ý dấu phân cách đó.

Đây là hình ảnh theo gợi ý của anh.


(Cũng có thể em nhớ nhầm mà)

 

[batman1]

Em cũng nhớ mang máng có một anh nói cái này rồi, chờ anh đó vào nhắc lại (có thể em nhớ nhầm).

Nhớ lại bài của siwtom ở chủ đề

http://www.giaiphapexcel.com/diendan/threads/tính-tổng-các-số-sau-dấu-hai-chấm.92760/#post-579064

Bài #5

Và được bác VetMini góp ý ở bài #13, và tôi cũng cám ơn ở bài #14.

Tóm lại là Mid(1 / 2, 2, 1)

 

[thang605555]

Bạn thử như thế này xem có được không
Code:
Function TT(Str As String)
Str = Replace(Str, ",", ".")
TT = Evaluate("=" & Str)
End Function


PacificPR, Yesterday at 4:13 PM

Cảm ơn bạn nhiều. Mình dùng ok rồi

 

[PacificPR]

Bạn thử như thế này xem có được không
Code:
Function TT(Str As String)
Str = Replace(Str, ",", ".")
TT = Evaluate("=" & Str)
End Function


PacificPR, Yesterday at 4:13 PM

Cảm ơn bạn nhiều. Mình dùng ok rồi

Hi hi. Vậy là máy của bạn cũng "Si đa" giống máy mình à

 

[Kiều Mạnh]

Mình đang từng bước viết lại code của file quản lý bán hàng mà mình đang sử dụng gặp phải 1 vấn đề rắc rối mà chưa xử lý xong úp bài nhờ các Bạn xử lý dùm
1/ Cùng một vấn đề như nhau mình sử Dụng DAO ghi dữ liệu từ Mảng trên Excel vào Table File Access thì chạy tốt ... Nhưng khi mình sử Dụng ADO để ghi vào thì nó báo lỗi "Data type mismatch in criteria expression" tạm dịch kiểu dữ liệu không phù hợp ....

2/ Mình có vào Tables\View chỉnh lại kiểu dữ liệu các kiểu vẫn không được ...cũng không biết sai cái gì ... code viết sai khúc nào ...???

3/ Code trong File mình làm 2 trường hợp là DAO và ADO ... nhờ các bạn xử lý dùm mình phần ADO nó lỗi không chạy được
xim cảm Ơn

Private Cnn As New ADODB.Connection
Private Rst As New ADODB.Recordset
Private AccPath As String, TableName As String
Private SQL As String, MyString As String
Rem ==========
Private Function Connection(ByVal AccPath As String) As ADODB.Connection
    Rem Tools/References - VBAProject/Microsoft ActiveX Data Objects 6.1 Library
    Set Cnn = New ADODB.Connection
    Cnn.Open ("Provider=Microsoft.ACE.OLEDB.12.0;Data Source=") _
        & AccPath & ";Persist Security Info=False"
    Set Connection = Cnn
End Function
Rem ==========
Private Sub CopyTableName(ByVal AccPath As String, ByVal TableName As String, ByVal Target As Range)
    Target.CopyFromRecordset Connection(AccPath).Execute(TableName)
End Sub
Rem ==========
Private Sub InsertQuery(ByVal Cnn As ADODB.Connection, ByVal TableName$, sArr(), _
                       Optional ByVal ColFilter = "", Optional ByVal DelTableName As Boolean = False)
    Dim i As Long, j As Long, Qry As String
    Set Rst = New ADODB.Recordset
    If ColFilter = "" Then ColFilter = 1
    If ColFilter = 0 Or ColFilter > UBound(sArr, 2) Then Exit Sub
'    On Error GoTo Errorhandler          ''Xu Ly loi khi mang Lon Hon tableName Or vv...
    Rem Set Cnn = Connection(AccPath)    ''Bo Tham So Cnn ap dung cho Chay Nhieu Sub truyen 1 Lan Tham So Cnn
    If DelTableName Then Cnn.Execute ("DELETE * FROM ") & TableName
    For i = 1 To UBound(sArr, 1)
        Qry = " INSERT INTO " & TableName & " VALUES(" & i
        If sArr(i, ColFilter) <> "" Then
            For j = 1 To UBound(sArr, 2)
                Qry = Qry & ", " & GetValue(sArr(i, j))
            Next
            Qry = Qry & " )"
            Rst.Open Qry, Cnn, adOpenStatic, adLockOptimistic
        End If
    Next
    Cnn.Close: Set Cnn = Nothing
'    Exit Sub
'Errorhandler:
'    MsgBox "Error #: " & Err.Number _
'        & vbCrLf & Err.Description
'    Rem Range("B1").Value = Err.Number & Err.Description            ''Search Google For Err
    Err.Clear
End Sub
Rem ==========
Public Sub Main_ADO()
    Dim Arr()
    TableName = "NhapXuatTon"
    AccPath = ThisWorkbook.Path & "\QLBHPN.accdb"
    Set Cnn = Connection(AccPath)
    Arr = Range("B4:I100").Value
    ''Call InsertQuery(Cnn, TableName, Arr(), 1, False)
    Call InsertQuery(Cnn, TableName, Arr(), 1, True)
    Sheet4.Range("K4:S1000").ClearContents
    Call CopyTableName(AccPath, TableName, Sheet4.Range("K4"))
End Sub

[code]

 

[truongvu317]

Không rõ nhập trực tiếp như này phải không? (Thiết lập control, dấu phân cách phần thập phân là dấu phẩy).

View attachment 192302

Converts a Microsoft Excel name to an object or a value.

Syntax

expression.Evaluate(Name)

expression A variable that represents an Application object.

Parameters

Name Required/Optional Data Type Description
Name Required Variant The name of the object, using the naming convention of Microsoft Excel.
Return Value
Variant

Remarks

The following types of names in Microsoft Excel can be used with this method:

• A1-style references. You can use any reference to a single cell in A1-style notation. All references are considered to be absolute references.
• Ranges. You can use the range, intersect, and union operators (colon, space, and comma, respectively) with references.
• Defined names. You can specify any name in the language of the macro.
• External references. You can use the ! operator to refer to a cell or to a name defined in another workbook — for example, Evaluate("[BOOK1.XLS]Sheet1!A1").
• Chart Objects. You can specify any chart object name, such as "Legend", "Plot Area", or "Series 1", to access the properties and methods of that object. For example, Charts("Chart1").Evaluate("Legend").Font.Name returns the name of the font used in the legend.

Em đã thử thì nó chạy theo kiểu của người Mỹ, tức là dấu chấm sẽ luôn được hiểu là dấu phân cách phần nghìn.

Sub TinhToan()

    Dim strFormual As String
    Dim vValue As Variant
    Dim strPhanCach As String
    
    strPhanCach = Mid(1.5, 2, 1)
    strFormual = "1,200"
    vValue = Sheet1.Evaluate(strFormual)
    Debug.Print "Gia tri bieu thuc voi dau phan cach """ & strPhanCach & """  la:" & CLng(vValue)
    
End Sub

Nhưng nó lại không chấp nhận dấu phẩy như code trên, sẽ chạy sai.

 

[befaint]

dấu chấm sẽ luôn được hiểu là dấu phân cách phần nghìn

Hình như ta chỉ xét dấu phân cách của phần thập phân, nếu có xét THÊM dấu phân cách phần nghìn, triệu, tỉ thì phải xử lý chuỗi số đó trước.

 

[batman1]

Em thay đổi thiết lập dấu phân cách trong Control rồi thử hàm ở bài #1540 thì 2 trường hợp: Dấu phân cách phần thập phân là dấu chấm/ Hoặc dấu phẩy thì đều cho kết quả đúng.

Em cũng nhớ mang máng có một anh nói cái này rồi, chờ anh đó vào nhắc lại (có thể em nhớ nhầm).

Cụ thể là thế này:
1. Ở ngoài trang tính thì dùng thiết lập trong "Use system separators". Mặc định thì là dùng thiết lập của system. Tức nếu system thiết lập dấu phẩy là dấu thập phân và "Use ..." để mặc định thì khi nhập vào A1 = 2,1 thi đó là số, còn nếu nhập vào A1 = 2.1 thì đó là chuỗi. Nếu system vẫn thiết lập dấu phẩy là dấu thập phân và "Use ..." chuyển thành dấu chấm là dấu thập phân thì khi nhập vào A1 = 2,1 thi đó là chuỗi, còn nếu nhập vào A1 = 2.1 thì đó là số.

2. Dù thiết lập "Use ..." mặc định hay thay đổi thì giá trị số (chỉ giá trị số thôi vì chuỗi thì luôn truyền y nguyên) truyền vào các code VBA luôn lấy thiết lập của system. Tức nếu system thiết lập dấu phẩy là dấu thập phân và "Use ..." để mặc định, tức dấu phẩy là dấu thập phân, thì với A1 = 2,1 giá trị truyền vào code là 2,1. Nếu thiết lập system vẫn thế nhưng người ta đổi "Use ..." thành: dấu chấm là dấu thập phân thì trên trang tính A = 2.1 là số, nhưng giá trị truyền vào code là 2,1 - lấy thiết lập của system.

3. Hàm Evaluate luôn luôn dùng dấu chấm là dấu thập phân. Nếu giá trị đưa vào chứa dấu chấm thì hàm Evaluate coi là số và tính toán. Nếu giá trị đưa vào chứa dấu phẩy thì hàm coi như là chuỗi và không tính toán được nên có lỗi.

Tại sao người hỏi nhìn thấy 2.1 là số mà lại có lỗi?
Do người ta không đưa tập tin nên tôi chỉ đoán mò là họ có thiết lập trong system dấu phẩy là dấu thập phân nhưng họ đã sửa mặc định "Use ..." thành dấu thập phân là dấu chấm. Lúc này A1 = 2.1 là số (điểm 1) nhưng giá trị truyền vào code là 2,1 (lấy thiết lập của system - điểm 2). Evaluate chỉ chấp nhận dấu chấm là dấu thập phân nên sẽ có lỗi.

Em thay đổi thiết lập dấu phân cách trong Control rồi thử hàm ở bài #1540 thì 2 trường hợp: Dấu phân cách phần thập phân là dấu chấm/ Hoặc dấu phẩy thì đều cho kết quả đúng.

Bởi bạn không thay đổi mặc định "Use ..." như người ta.
A. Bạn thiết lập trong system dấu chấm là dấu thập phân.
Lúc này nếu bạn nhập A1 = 2.1 thì đó là số. Giá trị truyền vào code cũng là 2.1 vì lấy theo thiết lập của system - điểm 2. Evaluate coi 2.1 là số - điểm 3, nên không có lỗi.
B. Bạn thiết lập trong system dấu phẩy là dấu thập phân.
Lúc này nếu bạn nhập A1 = 2.1 thì đó là chuỗi. Giá trị truyền vào code cũng là 2.1 vì đó là chuỗi chứ không là số. Evaluate coi 2.1 là số - điểm 3, nên không có lỗi

Nếu bây giờ vẫn thiết lập như điểm B nhưng bạn nhập A1 = 2,1 thì rõ ràng nó là số. Giá trị truyền vào code cũng là 2,1 vì lấy theo thiết lập của system - điểm 2. Nhưng Evaluate không coi 2,1 là số - điểm 3, nên sẽ có lỗi. Bạn thử sẽ thấy.

Do Evaluate chỉ chấp nhận dấu chấm (điểm 3) nên code của PacificPR luôn chuyển dấu phẩy nếu có thành dấu chấm.

 

[befaint]

Cụ thể là thế này:
1. Ở ngoài trang tính thì dùng thiết lập trong "Use system separators". Mặc định thì là dùng thiết lập của system. Tức nếu system thiết lập dấu phẩy là dấu thập phân và "Use ..." để mặc định thì khi nhập vào A1 = 2,1 thi đó là số, còn nếu nhập vào A1 = 2.1 thì đó là chuỗi. Nếu system vẫn thiết lập dấu phẩy là dấu thập phân và "Use ..." chuyển thành dấu chấm là dấu thập phân thì khi nhập vào A1 = 2,1 thi đó là chuỗi, còn nếu nhập vào A1 = 2.1 thì đó là số.

2. Dù thiết lập "Use ..." mặc định hay thay đổi thì giá trị số (chỉ giá trị số thôi vì chuỗi thì luôn truyền y nguyên) truyền vào các code VBA luôn lấy thiết lập của system. Tức nếu system thiết lập dấu phẩy là dấu thập phân và "Use ..." để mặc định, tức dấu phẩy là dấu thập phân, thì với A1 = 2,1 giá trị truyền vào code là 2,1. Nếu thiết lập system vẫn thế nhưng người ta đổi "Use ..." thành: dấu chấm là dấu thập phân thì trên trang tính A = 2.1 là số, nhưng giá trị truyền vào code là 2,1 - lấy thiết lập của system.

3. Hàm Evaluate luôn luôn dùng dấu chấm là dấu thập phân. Nếu giá trị đưa vào chứa dấu chấm thì hàm Evaluate coi là số và tính toán. Nếu giá trị đưa vào chứa dấu phẩy thì hàm coi như là chuỗi và không tính toán được nên có lỗi.

Tại sao người hỏi nhìn thấy 2.1 là số mà lại có lỗi?
Do người ta không đưa tập tin nên tôi chỉ đoán mò là họ có thiết lập trong system dấu phẩy là dấu thập phân nhưng họ đã sửa mặc định "Use ..." thành dấu thập phân là dấu chấm. Lúc này A1 = 2.1 là số (điểm 1) nhưng giá trị truyền vào code là 2,1 (lấy thiết lập của system - điểm 2). Evaluate chỉ chấp nhận dấu chấm là dấu thập phân nên sẽ có lỗi.


Bởi bạn không thay đổi mặc định "Use ..." như người ta.
A. Bạn thiết lập trong system dấu chấm là dấu thập phân.
Lúc này nếu bạn nhập A1 = 2.1 thì đó là số. Giá trị truyền vào code cũng là 2.1 vì lấy theo thiết lập của system - điểm 2. Evaluate coi 2.1 là số - điểm 3, nên không có lỗi.
B. Bạn thiết lập trong system dấu phẩy là dấu thập phân.
Lúc này nếu bạn nhập A1 = 2.1 thì đó là chuỗi. Giá trị truyền vào code cũng là 2.1 vì đó là chuỗi chứ không là số. Evaluate coi 2.1 là số - điểm 3, nên không có lỗi

Nếu bây giờ vẫn thiết lập như điểm B nhưng bạn nhập A1 = 2,1 thì rõ ràng nó là số. Giá trị truyền vào code cũng là 2,1 vì lấy theo thiết lập của system - điểm 2. Nhưng Evaluate không coi 2,1 là số - điểm 3, nên sẽ có lỗi. Bạn thử sẽ thấy.

Do Evaluate chỉ chấp nhận dấu chấm (điểm 3) nên code của PacificPR luôn chuyển dấu phẩy nếu có thành dấu chấm.

Vâng anh. Cảm ơn anh nhiều.
Nội dung em "nhớ mang máng" chính là điểm số 3 đó.

Chúc anh chiều - tối vui!

 

[Kiều Mạnh]

Mình đang từng bước viết lại code của file quản lý bán hàng mà mình đang sử dụng gặp phải 1 vấn đề rắc rối mà chưa xử lý xong úp bài nhờ các Bạn xử lý dùm
1/ Cùng một vấn đề như nhau mình sử Dụng DAO ghi dữ liệu từ Mảng trên Excel vào Table File Access thì chạy tốt ... Nhưng khi mình sử Dụng ADO để ghi vào thì nó báo lỗi "Data type mismatch in criteria expression" tạm dịch kiểu dữ liệu không phù hợp ....

2/ Mình có vào Tables\View chỉnh lại kiểu dữ liệu các kiểu vẫn không được ...cũng không biết sai cái gì ... code viết sai khúc nào ...???

3/ Code trong File mình làm 2 trường hợp là DAO và ADO ... nhờ các bạn xử lý dùm mình phần ADO nó lỗi không chạy được
xim cảm Ơn

Private Cnn As New ADODB.Connection
Private Rst As New ADODB.Recordset
Private AccPath As String, TableName As String
Private SQL As String, MyString As String
Rem ==========
Private Function Connection(ByVal AccPath As String) As ADODB.Connection
    Rem Tools/References - VBAProject/Microsoft ActiveX Data Objects 6.1 Library
    Set Cnn = New ADODB.Connection
    Cnn.Open ("Provider=Microsoft.ACE.OLEDB.12.0;Data Source=") _
        & AccPath & ";Persist Security Info=False"
    Set Connection = Cnn
End Function
Rem ==========
Private Sub CopyTableName(ByVal AccPath As String, ByVal TableName As String, ByVal Target As Range)
    Target.CopyFromRecordset Connection(AccPath).Execute(TableName)
End Sub
Rem ==========
Private Sub InsertQuery(ByVal Cnn As ADODB.Connection, ByVal TableName$, sArr(), _
                       Optional ByVal ColFilter = "", Optional ByVal DelTableName As Boolean = False)
    Dim i As Long, j As Long, Qry As String
    Set Rst = New ADODB.Recordset
    If ColFilter = "" Then ColFilter = 1
    If ColFilter = 0 Or ColFilter > UBound(sArr, 2) Then Exit Sub
'    On Error GoTo Errorhandler          ''Xu Ly loi khi mang Lon Hon tableName Or vv...
    Rem Set Cnn = Connection(AccPath)    ''Bo Tham So Cnn ap dung cho Chay Nhieu Sub truyen 1 Lan Tham So Cnn
    If DelTableName Then Cnn.Execute ("DELETE * FROM ") & TableName
    For i = 1 To UBound(sArr, 1)
        Qry = " INSERT INTO " & TableName & " VALUES(" & i
        If sArr(i, ColFilter) <> "" Then
            For j = 1 To UBound(sArr, 2)
                Qry = Qry & ", " & GetValue(sArr(i, j))
            Next
            Qry = Qry & " )"
            Rst.Open Qry, Cnn, adOpenStatic, adLockOptimistic
        End If
    Next
    Cnn.Close: Set Cnn = Nothing
'    Exit Sub
'Errorhandler:
'    MsgBox "Error #: " & Err.Number _
'        & vbCrLf & Err.Description
'    Rem Range("B1").Value = Err.Number & Err.Description            ''Search Google For Err
    Err.Clear
End Sub
Rem ==========
Public Sub Main_ADO()
    Dim Arr()
    TableName = "NhapXuatTon"
    AccPath = ThisWorkbook.Path & "\QLBHPN.accdb"
    Set Cnn = Connection(AccPath)
    Arr = Range("B4:I100").Value
    ''Call InsertQuery(Cnn, TableName, Arr(), 1, False)
    Call InsertQuery(Cnn, TableName, Arr(), 1, True)
    Sheet4.Range("K4:S1000").ClearContents
    Call CopyTableName(AccPath, TableName, Sheet4.Range("K4"))
End Sub

[code]

Bài này khó quá hay sao mà ko thấy bạn nào giúp mình một tẹo he

 

[Kiều Mạnh]

Bài #1555 Mạnh tạm thời xử lý xong
1/ Nó báo lỗi kiểu dữ liêu ko phù hợp là do trong mãng có dòng = Empty ...Nhưng mạnh vẫn suy nghĩ tại sao cùng 1 vấn đề đó mà DAO xử lý ok còn ADO báo Lỗi

2/ Nếu ta xét điều kiện trong Mãng mà = Empty thì cho nó = 0 lại OK ...tại sao ?!
If IsEmpty(sArr(x, y)) Then sArr(x, y) = 0

Phải chăng phải có cái gì đó cho nó ghi mới OK còn bỏ trống là lỗi

3/ Nếu ta chạy code đó cho TableName khác mà có Trường dữ liệu Format là Ngay/thang/nam thì nó lại báo lỗi ....Còn DAO thì kiểu gì cũng chơi hết ... Tại SAO ?!

4/ Bạn nào biết chỉ dùm mạnh một chút .... để Mạnh viết 1 cái Hàm InsertQuery Sử dụng ADO có thể xài cho nhiều trường hợp khác nhau như sử dụng DAO

Code sau đã điều chỉnh chạy tốt cho bài #1555

Public Sub InsertQuery(ByVal Cnn As ADODB.Connection, ByVal TableName$, sArr(), _
                       Optional ByVal ColFilter = "", Optional ByVal DelTableName As Boolean = False)
    Rem Cu Phap: Call InsertMySQL(Cnn, TableName, Arr(), 1, True)       ''Xoa Du Lieu cu Luu Moi
    Rem Cu Phap: Call InsertMySQL(Cnn, TableName, Arr(), 1, False)      ''Ghi du lieu Moi noi xuong
    Rem ColFilter = 1 Xet Cot trong Mang sArr() Neu co du lieu thi lay
    Dim x As Long, y As Long, Qry As String
    Set Rst = New ADODB.Recordset
    If ColFilter = "" Then ColFilter = 1
    If ColFilter = 0 Or ColFilter > UBound(sArr, 2) Then Exit Sub
    On Error GoTo Errorhandler
    If DelTableName Then Cnn.Execute ("DELETE * FROM ") & TableName
    For x = 1 To UBound(sArr, 1)
        Qry = " INSERT INTO " & TableName & " VALUES(" & x
        If sArr(x, ColFilter) <> "" Then
            For y = 1 To UBound(sArr, 2)
                If IsEmpty(sArr(x, y)) Then sArr(x, y) = 0
                Qry = Qry & ", " & GetValue(sArr(x, y))
            Next
            Qry = Qry & " )"
            Rst.Open Qry, Cnn, 3, 3
        End If
    Next
    Rst.Close: Set Rst = Nothing
    Cnn.Close: Set Cnn = Nothing
    Exit Sub
Errorhandler:
    MsgBox "Error #: " & Err.Number & vbCrLf & Err.Description
    Err.Clear
End Sub

Mong Các Bạn chỉ thêm... Mấy cái tại sao mà ngủ mất ngon
Xin cảm ơn

 

[themorzer]

Chào thầy!
em co file đính kèm, e học cachsc viết về array, nhưng e xử lý code trong một Sub, em muốn tạo hàm con khi nhật dong và cột vào ô excel,nhưng bị báo lỗi , mon thầy giúp dum em sai chổ nào
thanks

 

[giaiphap]

Chào thầy!
em co file đính kèm, e học cachsc viết về array, nhưng e xử lý code trong một Sub, em muốn tạo hàm con khi nhật dong và cột vào ô excel,nhưng bị báo lỗi , mon thầy giúp dum em sai chổ nào
thanks

Nếu viết hàm thì dùng Function chứ sao lại là Sub, báo lỗi là đúng rồi.

 

[ndu96081631]

Chào thầy!
em co file đính kèm, e học cachsc viết về array, nhưng e xử lý code trong một Sub, em muốn tạo hàm con khi nhật dong và cột vào ô excel,nhưng bị báo lỗi , mon thầy giúp dum em sai chổ nào
thanks

Bạn viết vầy:

RES = GPE(rowa, cola)

là sai cú pháp
Phải vầy mới đúng:

GPE rowa, cola

 

[themorzer]

Bạn viết vầy:

RES = GPE(rowa, cola)

là sai cú pháp
Phải vầy mới đúng:

GPE rowa, cola

cám ơn thầy, cũng với code đó: em muốn tách riêng ra hàm con, vì trong chương trình của em có nhiền điều kiện để chọn hàng và cột nên khi gọi cột 1 thì chỉ cần gọi chương trình con lên và chạy, e chưa hiểu lắm về cách xuất ra

xin lỗi thầy, em đã làm được, thầy xóa giúp em bài của em

 

[ndu96081631]

cám ơn thầy, cũng với code đó: em muốn tách riêng ra hàm con, vì trong chương trình của em có nhiền điều kiện để chọn hàng và cột nên khi gọi cột 1 thì chỉ cần gọi chương trình con lên và chạy, e chưa hiểu lắm về cách xuất ra

xin lỗi thầy, em đã làm được, thầy xóa giúp em bài của em

Tôi thắc mắc tại sao bài này bạn không dùng VLOOKUP?
Ví dụ:

=VLOOKUP(K4,$A$2:$I$14,MATCH(K5,$A$2:$I$2,0),0)

 

[themorzer]

Tôi thắc mắc tại sao bài này bạn không dùng VLOOKUP?
Ví dụ:

=VLOOKUP(K4,$A$2:$I$14,MATCH(K5,$A$2:$I$2,0),0)

vì e đang lam chương trinh tim kiếm NVL, nên k xài Vlookup
đính kèm là 1 phần chương trình
nhưng khi em gọi hàm thì báo lỗi Byref argument type mismatch

 

[ndu96081631]

vì e đang lam chương trinh tim kiếm NVL, nên k xài Vlookup
đính kèm là 1 phần chương trình
nhưng khi em gọi hàm thì báo lỗi Byref argument type mismatch

Nó không chịu byRef thì mình byVal

Function terminal(ByVal ter As String, ByVal wire As String, Darr())
  Dim Arr(1 To 100, 1 To 3), i As Long, j As Long, iR As Long, DK As String
  For i = 2 To UBound(Darr)
    If Darr(i, 1) = ter Then
      For j = 2 To UBound(Darr, 2)
        If Darr(1, j) = wire Then
          terminal = Darr(i, j)
          Exit Function
        End If
      Next j
    End If
  Next i
End Function

Sửa đại vậy thôi chứ chương trình của bạn muốn ngon cần phải cải thiện rất nhiều

 

[themorzer]

Nó không chịu byRef thì mình byVal

Function terminal(ByVal ter As String, ByVal wire As String, Darr())
  Dim Arr(1 To 100, 1 To 3), i As Long, j As Long, iR As Long, DK As String
  For i = 2 To UBound(Darr)
    If Darr(i, 1) = ter Then
      For j = 2 To UBound(Darr, 2)
        If Darr(1, j) = wire Then
          terminal = Darr(i, j)
          Exit Function
        End If
      Next j
    End If
  Next i
End Function

Sửa đại vậy thôi chứ chương trình của bạn muốn ngon cần phải cải thiện rất nhiều

cám ơn thầy

 

[themorzer]

cũng chương trình của em, muốn tạo Combobox theo dòng đầu tiên trong Sheet Terminal, nhưng viết chương trình con và xuất theo điều kiện:

For i = 2 To UBound(Darr)
    If Darr(i, 1) = ter Then
      For j = 2 To UBound(Darr, 2)
        If Darr(i, j) > 0 Then
                       Darr(1, j)
         End If  
      Next j
End If
Next i
[code]

em o viết theo Dictionary nhưng chưa hiểu củ pháp

 

[mkvikyno]

Chào các anh chị.
Hiện tại tôi đang tập sử dụng VBA để viết 1 số macro tích hợp vào file theo dõi thông tin của mình, nhưng gần đây file xuất hiện lỗi error in loading DLL.
Hiện tại tôi không biết nguyên nhân như thế nào, mong các bác chỉ giúp

 

[NguyenNgocThuHien]

Chào các anh chị.
Hiện tại tôi đang tập sử dụng VBA để viết 1 số macro tích hợp vào file theo dõi thông tin của mình, nhưng gần đây file xuất hiện lỗi error in loading DLL.
Hiện tại tôi không biết nguyên nhân như thế nào, mong các bác chỉ giúp

Vào tool/references rồi bỏ những cái có chữ mising đi.

 

[thanhnt1910]

Anh chị cho em hỏi, em có làm đoạn macro bảng chấm công để lấy dữ liệu từ 2 file. Nhưng hiện tại em đang mắc 1 vấn đề là nếu kế hoạch tháng 2 đều có trong 2 file PXDuc_201802 và PXDuc_201803 thì khi chọn cả 2 file thì chỉ lấy dữ liệu của tháng nằm trong kế hoạch ở sheet ThongSoChung, em mới làm được nếu file có kế hoạch từ ngày mùng 1 đến cuối tháng còn trường hợp trên em chưa làm được. Mong anh chị gợi ý giúp em ạ. Em cảm ơn.

 

[hunganh.nguyen]

Chào các anh chị em GPE!
Mình có 2 File đính kèm
1/. Master.xlsb : File nguồn
2/. Report.xlsx : File lưu

Mình có nhờ tạo code để copy sheet Report và chọn lưu sang File Report theo từng Sheet theo từng lần chọn.
Nhưng khi thực hiện xong thì ở File lưu có thêm phần "khuyến mãi" không mong muốn


Anh chị em nào biết cách loại bỏ phần "khuyến mãi " này thì giúp mình nhé!
Mình cám ơn nhiều!

 

[bigbabol89]

Em chào các anh. Nhờ sự trợ giúp của anh Ba Tê mà em có được 1 file giúp ích công việc rất nhiều. Tuy nhiên hiện tại có 1 số vấn đề phát sinh. Các anh giúp em với được không ạ. Em cám ơn !

 

[Ba Tê]

Em chào các anh. Nhờ sự trợ giúp của anh Ba Tê mà em có được 1 file giúp ích công việc rất nhiều. Tuy nhiên hiện tại có 1 số vấn đề phát sinh. Các anh giúp em với được không ạ. Em cám ơn !

1. Bạn xem file này có khác biệt gì với code trong file trước rồi ngẫm ra cái "chèn thêm cột".
2. Bạn muốn lọc theo điều kiện nào thì cho code "biết" mà làm luôn, sao phải filter dữ liệu làm gì? Trong file là lọc theo điều kiện cột F (Object), nếu nhiều điều kiện nữa thì tính nữa.

 

[bigbabol89]

1. Bạn xem file này có khác biệt gì với code trong file trước rồi ngẫm ra cái "chèn thêm cột".
2. Bạn muốn lọc theo điều kiện nào thì cho code "biết" mà làm luôn, sao phải filter dữ liệu làm gì? Trong file là lọc theo điều kiện cột F (Object), nếu nhiều điều kiện nữa thì tính nữa.

Em cám ơn anh BaTe :
1. Em đã hiểu cách làm thế nào để chèn thêm cột rồi. Nhưng mà khi em chạy code thì các dữ liệu ở những cột xen giữa ( cột mới thêm vào ) bị mất hết. Anh xem giúp em với
2. Thực ra thì file này, em chỉ sử dụng ở sheet IT2003 thôi. Còn sheet kia là người khác dùng, và vì họ là những người gần như chỉ biết nhập liệu nên có những trường hợp nhân viên không còn trong bảng nữa nhưng họ không xóa đi mà vẫn để đấy, sau đó bỏ filter bạn nghỉ kia đi => Ý là chỉ hiển thị những người đang làm việc hiện tại cho em xem => Như vậy khi dùng code ở IT2003 thì vẫn sẽ hiện những người đã nghỉ.
Em thấy đưa điều kiện để các anh giúp không khó, nhưng một thời gian điều kiện sẽ lại thay đổi
====> Vì vậy, nếu code làm được em chỉ mong kết quả ở IT2003 sẽ hiện kết quả ở hàng HR Only của các ô hiện hành ( không lấy kq các ô đã filter đi ).
Nếu không được cũng không sao, vì được đến bước này rồi thì em cũng rất chi là thỏa mãn.
Em cám ơn.

 

[Nguyễn Hồng Quang]

Chào các anh, chị , em và các bạn trên GPE
Trong Module1 (ModData), sử dụng code để lấy dữ liệu từ 8 dòng trên Sheet Input đưa sang bên sheet PartsData
Tuy nhiên khi mình kết thúc code bằng lệnh chọn dòng dưới cùng của cột A ở sheet PartsData (như trong hình 1)

Sheets("PartsData").Select
Cells(nextRow, "A").Select

thì Excel lập tức báo lỗi (như trong hình 2)
Mà hễ bình bỏ dòng lệnh đó ra khỏi code thì file lại chạy ngon lành
Mình không hiểu tại sao. Rất mong mọi người giúp đỡ xử lý lỗi này

 

[ndu96081631]

Chào các anh, chị , em và các bạn trên GPE
Trong Module1 (ModData), sử dụng code để lấy dữ liệu từ 8 dòng trên Sheet Input đưa sang bên sheet PartsData
Tuy nhiên khi mình kết thúc code bằng lệnh chọn dòng dưới cùng của cột A ở sheet PartsData (như trong hình 1)

Sheets("PartsData").Select
Cells(nextRow, "A").Select

thì Excel lập tức báo lỗi (như trong hình 2)
Mà hễ bình bỏ dòng lệnh đó ra khỏi code thì file lại chạy ngon lành
Mình không hiểu tại sao. Rất mong mọi người giúp đỡ xử lý lỗi này

Mình chạy có thấy bị gì đâu

 

[Nguyễn Hồng Quang]

Mình chạy có thấy bị gì đâu

Vậy có thể do máy của em bị lỗi rồi; không phải do file. Cảm ơn anh

 

[vanthinh3101]

Chào các anh, chị , em và các bạn trên GPE
Trong Module1 (ModData), sử dụng code để lấy dữ liệu từ 8 dòng trên Sheet Input đưa sang bên sheet PartsData
Tuy nhiên khi mình kết thúc code bằng lệnh chọn dòng dưới cùng của cột A ở sheet PartsData (như trong hình 1)

Sheets("PartsData").Select
Cells(nextRow, "A").Select

thì Excel lập tức báo lỗi (như trong hình 2)
Mà hễ bình bỏ dòng lệnh đó ra khỏi code thì file lại chạy ngon lành
Mình không hiểu tại sao. Rất mong mọi người giúp đỡ xử lý lỗi này

Code của anh dài nên em luận không ra được.
Em viết code mảng cho ngắn gọn, hi vọng đúng ý của anh.

Sub GPE()
    Dim sArr(), dArr()
    Dim I As Long, j As Long, K As Long, D As Date, lR As Long
    
    D = wksPartsDataEntry.Range("D3")
    sArr() = wksPartsDataEntry.Range("B7", wksPartsDataEntry.Range("B7").End(xlDown)).Resize(, 8).Value
    ReDim dArr(1 To UBound(sArr, 1), 1 To 11)
    
    For I = 1 To UBound(sArr, 1)
        dArr(1, 1) = Format(Now, "mm/dd/yyyy hh:mm:ss")
        dArr(1, 2) = Application.UserName
        K = K + 1
        dArr(K, 3) = D
        For j = 1 To 8
            dArr(K, j + 3) = sArr(I, j)
        Next j
    Next I
    
    lR = wksPartsData.Range("C" & Rows.Count).End(xlUp).Row + 1
    wksPartsData.Range("A" & lR).Resize(K, 11) = dArr
End Sub

 

[thangteo]

Nhờ tất cả mọi người xem qua file và chỉnh sửa code lại theo ý như thế này ạ:
1. Trong form: khi giây chạy về "0:00" thì kêu chuông, hiện tại thì giây chạy về "0:00" nhưng sau 1 giây nó mới kêu chuông. Ý muốn là khi giây nhảy về "0:00" là phải kêu chuông ngay mà không có trễ 1 giây ạ. (bắt đầu chạy là nhấn Enter).
2. Có cách nào để chọn trực tiếp 1 khoảng thời gian bất kỳ ngay trong chỗ thời gian (trong form) để khi nhấn enter thì bắt đầu chạy từ khoảng thời gian bất kỳ đó không ạ, kể cả chỗ hiển thị số Hiệp (trong form) nữa ạ, nếu chọn ngẫu nhiên là Hiệp 2 thì sau khi chạy hết khoảng thời gian ở hiệp đó thì sẽ chuyển sang Hiệp 3 tiếp theo ạ.(ví dụ: thi đấu 3 Hiệp và thời gian thi đấu là 2', tại thời điểm Hiệp 2 đang diễn ra ở 1':25", gặp sự cố mất điện chẳng hạn, sau khi có điện ta chọn lại thời điểm Hiệp 2 và khoảng thời gian 1':25" đó để cho thi đấu tiếp. Yêu cầu là sau khi hết khoảng thời gian đó thì sẽ tiếp tục sang Hiệp 3 và vẫn thời gian thi đấu là 2'. )
----------
Mong sự giúp đỡ của mọi người. File này là anh Huuthang_bd đã làm cho em, vì điều kiện và thời gian chưa cho phép nên anh ấy chưa chỉnh sửa được nên em xin phép anh ấy đăng lên đây để mọi người chỉnh sửa giúp ạ. Cảm ơn mọi người.

 

[duynguyenkk]

Nhờ tất cả mọi người xem code và sữa giúp em với e xuất ra nó không đúng kết quả tổng hợp, với em muốn bỏ nhac chọn vùng dữ liệu ( mặc định là K8: cuối cột P có dữ liệu), và loại bỏ mã ko có đơn vị

Option Explicit

' Dinh nghia kieu nguoi dung cho loai vat tu
' moi loaij vat tu gom co ma so , ten,don vij, khoi luong
Type LoaiVatTu
    Maso As String
    Donvi As String
    Khoiluong As String
End Type

' Lap danh sach cac loai vat tu

Public Sub DanhSachVT()
    Dim R As Range 'Pham vi trong bang vat lieu can phan tich
    Dim DanhSachVT() As LoaiVatTu ' Mang dong chua danhsach vat tu
    Dim i As Long ' chi so mang
    Dim k As Range ' bien nay dung de duyet bang du lieu trong R

Set R = Application.InputBox("Cho?n vu`ng du~ liê?u câ`n tô?ng hop", Type:=8)
    i = 0 'chi so dau tien cua mang vat tu la 0
    Dim ii As Long
    Dim ok As Boolean
    ' Doc du lieu tu sheet "Phan Tich Vat Tu"
    For Each k In R.Columns(1).Cells
        If Trim(k.Value) <> "" Then
            If i = 0 Then 'vat tu dau tien trong danh sach
                ReDim Preserve DanhSachVT(i) 'khai bao lai mang
                'gan du lieu cho vat tu dau tien
                DanhSachVT(i).Maso = Trim(k.Value)
                DanhSachVT(i).Donvi = Trim(k.Offset(0, 6).Value)
                DanhSachVT(i).Khoiluong = Trim(k.Offset(0, 5).Value)
                i = i + 1 'tang chi so mang len 1
            Else 'neu danh sach vat tu lon hon 1
                ok = True
                For ii = 0 To i - 1
                    'vat tu nay da co trong danh sach
                    If DanhSachVT(ii).Maso = Trim(k.Value) Then
                        ok = False
                        DanhSachVT(ii).Khoiluong = DanhSachVT(ii).Khoiluong
                        Exit For
                    End If
                Next ii
                ' vat tu chua co ten trong danh sach
                If ok Then
                    ReDim Preserve DanhSachVT(i)
                    DanhSachVT(i).Maso = Trim(k.Value)
                    DanhSachVT(i).Donvi = Trim(k.Offset(0, 6).Value)
                    DanhSachVT(i).Khoiluong = Trim(k.Offset(0, 5).Value)
                    i = i + 1 'tang chi so mang len 1
                End If
            End If
        End If
    Next
    'Ghi ket qua ra excel, trong sheet "THVT"
    Dim j As Long
    Dim row As Long
 
    row = 7 ' bat dau ghi du lieu
    For j = LBound(DanhSachVT) To UBound(DanhSachVT)
        ThisWorkbook.Worksheets("thvt").Cells(row + j, 1).Value = j + 1
        ThisWorkbook.Worksheets("thvt").Cells(row + j, 2).Value = DanhSachVT(j).Maso
        ThisWorkbook.Worksheets("thvt").Cells(row + j, 3).Value = DanhSachVT(j).Donvi
        ThisWorkbook.Worksheets("thvt").Cells(row + j, 4).Value = DanhSachVT(j).Khoiluong
    Next j
    MsgBox "Ket thuc"
    End Sub

 

[Nguyễn Hồng Quang]

Code của anh dài nên em luận không ra được.
Em viết code mảng cho ngắn gọn, hi vọng đúng ý của anh.

Sub GPE()
    Dim sArr(), dArr()
    Dim I As Long, j As Long, K As Long, D As Date, lR As Long
  
    D = wksPartsDataEntry.Range("D3")
    sArr() = wksPartsDataEntry.Range("B7", wksPartsDataEntry.Range("B7").End(xlDown)).Resize(, 8).Value
    ReDim dArr(1 To UBound(sArr, 1), 1 To 11)
  
    For I = 1 To UBound(sArr, 1)
        dArr(1, 1) = Format(Now, "mm/dd/yyyy hh:mm:ss")
        dArr(1, 2) = Application.UserName
        K = K + 1
        dArr(K, 3) = D
        For j = 1 To 8
            dArr(K, j + 3) = sArr(I, j)
        Next j
    Next I
  
    lR = wksPartsData.Range("C" & Rows.Count).End(xlUp).Row + 1
    wksPartsData.Range("A" & lR).Resize(K, 11) = dArr
End Sub

Code của Vanthinh luôn gọn gàng và tốc độ nhanh đúng phong cách của anh Nguyễn Duy Tuân; Cảm ơn Vanthinh3101 nhiều, Chúc bạn và gia đình luôn mạnh khỏe, gặp nhiều thành công trong công việc. Hẹn gặp lại bạn mùa hè năm nay nhé

 

[batman1]

Code của Vanthinh luôn gọn gàng và tốc độ nhanh đúng phong cách của anh Nguyễn Duy Tuân;

For I = 1 To UBound(sArr, 1)
        dArr(1, 1) = Format(Now, "mm/dd/yyyy hh:mm:ss")
        dArr(1, 2) = Application.UserName
...

Thiết lập giá trị cho 2 phần tử cố định dArr(1, 1), dArr(1, 2) trong vòng lặp? Nếu UBound(sArr, 1) = 100, 1000 thì cũng làm 100, 1000 lần cái việc chỉ cần làm 1 lần?

Tất nhiên ở đây chỉ có max 8 dòng nhưng tôi nói về nguyên tắc, về phong cách lập trình - vì bạn đang nói về phong cách của Tuân. Có lẽ Tuân sẽ cho 2 dòng trên ra ngoài vòng lặp chăng?

Với code thế này mà bạn nói thế thì tôi không biết bạn khen tác giả hay chê Nguyễn Duy Tuân.

 

[VetMini]

Trèo lên mụt đuôi kèo vuốt nhằm con mèo đuôi cụt.

 

[excelbee]

Chào thầy,
Em có bài tập VBA về Xác định 1 số có phải là Số nguyên tố hay không, nhưng em không hiểu đoạn code này là như thế nào. Mong thầy giải thích giúp em. Cảm ơn thầy.

Sub xet_snt()

Dim so, i, dem As Integer

so = Range("b1").Value

dem = 0

For i = 1 To so
If so Mod i = 0 Then
dem = dem + 1
End If
Next i

If dem = 2 Then
Range("b2").Value = so & " la so nguyen to"
Else
Range("b2").Value = so & " khong la so nguyen to"
End If
End Sub

 

[batman1]

Sub xet_snt()
  
    Dim so, i, dem As Integer
  
    so = Range("b1").Value
  
    dem = 0
  
    For i = 1 To so
        If so Mod i = 0 Then
            dem = dem + 1
        End If
    Next i
      
    If dem = 2 Then
        Range("b2").Value = so & " la so nguyen to"
    Else
        Range("b2").Value = so & " khong la so nguyen to"
    End If
End Sub

Ta biết rằng số n là số nguyên tố khi và chỉ khi chia hết cho 1 và cho chính nó.
dem = 2 có nghĩa là số tự nhiên so chỉ chia hết cho 1 và cho chính nó. Vì vậy nó là số nguyên tố.

Chỉ cần một số chú ý nhỏ thì số vòng lặp sẽ giảm rất nhiều.
1. Rõ rằng mọi số chẵn lớn hơn 2 không thể là số nguyên tố vì ngoài 1 và chính nó thì nó còn chia hết cho 2.
2. Nếu vd. dem = 3 thì rõ ràng điều kiện về sau If dem = 2 Then sẽ không thỏa vậy chả lý gì tiếp tục vòng lặp khi tình huống đó sảy ra. Vd. so = 2*3*10^6 = 6000000. Với 3 vòng lặp i = 1, 2, 3 đã có dem = 3. Chả lý gì thực hiện tiếp 5999997 vòng lặp khi biết trước sau thì cũng có dem = 2 = FALSE.
---------
Tất nhiên bài trong Excel thì chỉ dùng thuật toán đơn giản. Nhưng thuật toán trên có nhiều vòng không cần thiết. Ta chỉ xét trường hợp dùng kiến thức lớp 1, tức coi như không biết các định lý, thuật toán cao siêu.

Ta biết rằng nếu n là hợp số thì nó là tích của ít nhất 2 số tự nhiên > 1. Đây là kiến thức lớp 1 nên không có gì là cao siêu. Tức nếu n là hợp số thì tồn tại 2 ≤ a ≤ b sao cho n = a*b
Gọi p là một ước nguyên tố của a, tức a = p*c ta có n = p*c*b = p*d (p ≤ a ≤ b ≤ b*c = d)
=> p² ≤ p*d = n => p ≤ √n
Tức nếu n là hợp số thì nó phải có ít nhất 1 ước số nguyên tố nhỏ hơn hoặc bằng √n. Tất nhiên nếu n có ước ≤ √n thì nó phải là hợp số (vì số nguyên tố không chia hết cho cho số tự nhiên lớn hơn 1 và nhỏ hơn nó)

Chỉ với chú ý nhỏ này mà ta có code

Function IsPrime(ByVal so As Long) As Boolean
Dim k As Long, a As Long
    If so < 2 Or ((so > 2) And (so Mod 2 = 0)) Then Exit Function
    a = Int(Sqr(so))
    For k = 3 To a Step 2
        If so Mod k = 0 Then Exit For
    Next k
    IsPrime = k > a
End Function

 

[VetMini]

Phụ thêm cho bài #1588 ở trên:

Bài toán xét số nguyên tố hình như là bài toán căn bản mà giáo viên dạy lập trình hầu như luôn luôn sẽ dùng để dạy. Nhất là khi bạn học lập trình căn bản như Pascal và C.
(tôi dùng từ "hình như" và "hầu như" là vì tôi nhận thấy khuynh hướng bây giờ như vậy)

Nó đặc biệt ở chỗ là 99% học sinh sẽ giản dị giải theo kiểu chia thử từ 1 đến n và đếm số ước. Theo nguyên tắc số nguyên tố chỉ chia chẵn cho 1 và chính nó, hễ số ước số lớn hơn 2 thì không phải là nguyên tố. Đây là giải thuật dựa trên định nghĩa số nguyên tố, và đó là giải thuật mà code bài #1587 được viết theo. Giải thuật hoàn toàn đúng nhưng đối với toán lẫn lập trình thì nó là chưa đạt - nếu tôi là người chấm bài thì tôi chấm tối đa 5/10

Theo luật toán lẫn lập trình, bài giải phải cộng thêm sự suy nghĩ và áp dụng những thủ thuật rút ngắn. Ví dụ bạn ra bài toán cho trẻ em: tìm những số chia chẵn cho 5; trẻ nào tìm bằng cách chia từng số cho 5 thì sẽ đạt 2/10; bài toán giải đúng phải là tìm những số kết bằng 5 hoặc 0.

Khi học toán số, lúc học tới số nguyên tố thì bạn cũng đồng thời học tính chất và cách xét:
1. ba số đầu 1,2,3 là số nguyên tố. Vì vậy chỉ xét những số lớn hơn 3
2. số nguyên tố lớn hơn 3 không thể là số chẵn. Vì vậy điều kiện kế đó là chỉ cần xét số lẻ
3. sau khi đã khẳng định là số lẻ rồi thì lúc chia thử để tìm ước số chỉ cần thử những số lẻ, bởi vì số chẵn đương nhiên không chia chẵn.
4. chỉ cần tìm được thêm 1 ước số rồi thì ngừng. Tìm thêm vô ích
5. theo luật đối xứng của ước số trong toán số, nếu b là ước số của a thì phải có một c sao cho c*b = a; và nếu b < căn 2 a thì c > căn 2 a, và ngược lại. Vì vậy, chỉ cần xét các ước số nhỏ hơn hoặc bằng số đã cho mà thôi.

Tóm lại, để xét n có phải là số nguyên tố thì tuần tự làm như sau:
(i) nếu n nhỏ hơn hoặc bằng 3 thì là số nguyên tố
(ii) nếu số là số chẵn thì không phải là số nguyên tố, không cần xét tiếp.
(iii) vòng lặp i từ 3 đến căn 2 của n; bước 2 (chỉ tính những số lẻ)
(iii).(a) nếu i chia chẵn n thì i là 1 ước số khác của n; thoát vòng lặp
(iv) hết vòng lặp, xét lại xem i đã tiến quá căn 2 của n chưa, nếu chưa thì là vòng lặp thoát sớm -> không phải số nguyên tố

 

[themorzer]

Mình có đoạn code sau:
mình chưa hiểu vì sao Combobox không xóa được,
nhưng với đoạn code này trong Combobox được nạp code thuộc mảng thì Clear được, vậy đối với trường hợp này thi xử lý như thế nào ngoài việc gán cho nó giá trị "".

Private Sub CommandButton1_Click()
Me.ComboBox1.Clear
Me.ComboBox2.Clear
Me.ComboBox3.Clear
End Sub 
[CODE]

và sao với đoạn code này thì 1 số Form nó setfocus được, 1 số không set được

[code]
Private Sub UserForm_Initialize()
Me.ComboBox2.SetFocus
End Sub
[code]

 

[Quy Vu]

Sub tim_sheet()
Dim Tieude As String
Dim Timduoc As Boolean
Dim I As Integer, sosheet As Long
Dim TenSheet As String
Tieu de = "www.giaiphapexcel.com"
sosheet = ActiveSheet.Sheets.Count 'xac dinh so sheet trong workbook'
timtiep:
Tensheet=lcase(application.inputbox("Ban go ten cua sheet:",Tieude)
If TenSheet = "False" Then Exit Sub 'neu nguoi dung bam cancel
If TenSheet = "" Then
MsgBox "ban hay nhap ten sheet de tim:", vbExclamation, Tieude
GoTo timtiep 'quaytro lai nhan tim tiep
End If
Timduoc = False
For I = 1 To sosheet
If InStr(1, LCase(Sheets(I).Name), TenSheet) > 0 Then
Timduoc = True
Sheets(I).Select
If Msgbox ("Da tim duoc sheet co ten""""&TenSheet&""".Ban cos muon tim tiep khong?",vbYesNo+vbQuestion,Tieude)=vbYes Then Goto Timtiep
Exit For
End If
Next 'Neu khong tim duoc sheet
If Not Timduoc Then
msgbox " Khong tim thay sheet co ten """ & Tensheet&""",",vbExclamation, Tieude
endsub

Em không hiểu lắm ở phần nhãn Timtiep, cách thức tạo một nhãn như vậy, công dụng anh chị giải đáp giúp em với ạ, e cám ơn

 

[♫ђöล♥ßล†♥†µ♫]

Sub tim_sheet()
Dim Tieude As String
Dim Timduoc As Boolean
Dim I As Integer, sosheet As Long
Dim TenSheet As String
Tieu de = "www.giaiphapexcel.com"
sosheet = ActiveSheet.Sheets.Count 'xac dinh so sheet trong workbook'
timtiep:
Tensheet=lcase(application.inputbox("Ban go ten cua sheet:",Tieude)
If TenSheet = "False" Then Exit Sub 'neu nguoi dung bam cancel
If TenSheet = "" Then
MsgBox "ban hay nhap ten sheet de tim:", vbExclamation, Tieude
GoTo timtiep 'quaytro lai nhan tim tiep
End If
Timduoc = False
For I = 1 To sosheet
If InStr(1, LCase(Sheets(I).Name), TenSheet) > 0 Then
Timduoc = True
Sheets(I).Select
If Msgbox ("Da tim duoc sheet co ten""""&TenSheet&""".Ban cos muon tim tiep khong?",vbYesNo+vbQuestion,Tieude)=vbYes Then Goto Timtiep
Exit For
End If
Next 'Neu khong tim duoc sheet
If Not Timduoc Then
msgbox " Khong tim thay sheet co ten """ & Tensheet&""",",vbExclamation, Tieude
endsub

Em không hiểu lắm ở phần nhãn Timtiep, cách thức tạo một nhãn như vậy, công dụng anh chị giải đáp giúp em với ạ, e cám ơn

Bạn bấm F8 cho duyệt qua từng dòng lệnh khi nào đến chỗ Goto timtiep xong rồi nó nhảy đến đâu thì bạn sẽ hiểu ngay thôi
Như Code trên thì qua Goto Timtiep thì nó sẽ nhảy đến Timtiep:
Sau câu lênh Goto thì bạn có thể đặt 1 tên bất kỳ như Tieptuc, Tiep hoặc gì gì đó (trong code trên là Timtiep)

 

[VetMini]

Bạn bấm F8 cho duyệt qua từng dòng lệnh khi nào đến chỗ Goto timtiep xong rồi nó nhảy đến đâu thì bạn sẽ hiểu ngay thôi
Như Code trên thì qua Goto Timtiep thì nó sẽ nhảy đến Timtiep:
Sau câu lênh Goto thì bạn có thể đặt 1 tên bất kỳ như Tieptuc, Tiep hoặc gì gì đó (trong code trên là Timtiep)

Code này sai. Trước khi giải thích được thì phải hỏi người ta lấy code ở đâu ra.

 

[ThaiDieuAnh]

Các anh chị giúp em sửa lỗi code này với ạ

Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
If Not Intersect(Range("B5:B" & [C65500].End(xlUp).Row), Target) Is Nothing And Target.Count = 1 Then
            UserForm1.Show
            Cancel = True
    End If
 End Sub

Ví dụ khi em chọn toàn bộ bảng tính hoặc từ hàng nào đó đến hàng cuối cùng hoặc cột nào đó đến cột cuối cùng rồi kích chuột phải thì bị lỗi ạ, em xin cảm ơn

 

[phulien1902]

Các anh chị giúp em sửa lỗi code này với ạ

Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
If Not Intersect(Range("B5:B" & [C65500].End(xlUp).Row), Target) Is Nothing And Target.Count = 1 Then
            UserForm1.Show
            Cancel = True
    End If
End Sub

Ví dụ khi em chọn toàn bộ bảng tính hoặc từ hàng nào đó đến hàng cuối cùng hoặc cột nào đó đến cột cuối cùng rồi kích chuột phải thì bị lỗi ạ, em xin cảm ơn

Vì sự kiện Click phải chuột của bạn chỉ sử hoạt động khi Target=1 và chọn trong cột B( B5-->dòng cuối cùng cột C).
Vì vậy để sử dụng cho nhiều cột bạn thử thay:

B5:B

bằng:

B5:AB

Lưu ý: Chỉ Click phải chuột vào 1 Cell.

 

[ThaiDieuAnh]

Vì sự kiện Click phải chuột của bạn chỉ sử hoạt động khi Target=1 và chọn trong cột B( B5-->dòng cuối cùng cột C).
Vì vậy để sử dụng cho nhiều cột bạn thử thay:

B5:B

bằng:

B5:AB

Lưu ý: Chỉ Click phải chuột vào 1 Cell.

Bác hiểu sai câu hỏi của em rồi ạ, em muốn sử dụng cho 1 côt và một cell nên mới khai báo
Range("B5:B" & [C65500].End(xlUp).Row)
Code vẫn chạy ngon lành, chỉ vướng lỗi là khi em chọn toàn bộ bảng tính hoặc từ hàng nào đó đến hàng cuối cùng hoặc cột nào đó đến cột cuối cùng rồi kích chuột phải thì bị lỗi ạ

 

[♫ђöล♥ßล†♥†µ♫]

Bác hiểu sai câu hỏi của em rồi ạ, em muốn sử dụng cho 1 côt và một cell nên mới khai báo
Range("B5:B" & [C65500].End(xlUp).Row)
Code vẫn chạy ngon lành, chỉ vướng lỗi là khi em chọn toàn bộ bảng tính hoặc từ hàng nào đó đến hàng cuối cùng hoặc cột nào đó đến cột cuối cùng rồi kích chuột phải thì bị lỗi ạ

Bạn thử thêm dòng này vào xem: On Error Resume Next

 

[ThaiDieuAnh]

Bạn thử thêm dòng này vào xem: On Error Resume Next

Thêm dong đó form lại hiện lên bác ạ. Mà thế thì không đúng

 

[♫ђöล♥ßล†♥†µ♫]

Thêm dong đó form lại hiện lên bác ạ. Mà thế thì không đúng

Hay là như vầy nhỉ

 

[ThaiDieuAnh]

Hay là như vầy nhỉ

Cảm ơn bác ạ, đúng ý em rồi

 

[HieuCD]

Các anh chị giúp em sửa lỗi code này với ạ

Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
If Not Intersect(Range("B5:B" & [C65500].End(xlUp).Row), Target) Is Nothing And Target.Count = 1 Then
            UserForm1.Show
            Cancel = True
    End If
End Sub

Ví dụ khi em chọn toàn bộ bảng tính hoặc từ hàng nào đó đến hàng cuối cùng hoặc cột nào đó đến cột cuối cùng rồi kích chuột phải thì bị lỗi ạ, em xin cảm ơn

If Not Intersect(Range("B5:B" & [C65500].End(xlUp).Row), Target) Is Nothing And Target.Rows.Count = 1 Then

 

[huongmuine]

Nhờ các anh chị xem giúp:
Trong file khi mình nhập dữ liệu vào cột E thì code chạy
Nhưng khi copy và dán vào thì code không chạy.
Vậy mình phải sửa code như thế nào để code thực hiện lệnh khi copy và dán dữ liệu.
Xin cảm ơn.

 

[huongmuine]

Thêm 1 vòng lặp For each sau dòng If Target.Rows.Count = 1 Then nữa là được

Nghĩa là:

Dim Clls as Range
If Target.Rows.Count = 1 Then
For Each Clls In Target
.......
Next
End if

[QUOTE="
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Clls As Range
If Target.Column = 5 Then
If Target.Rows.Count = 1 Then
For Each Clls In Target
If Target <> Empty Then
Target.Offset(, 1).Value = "=IF(LEN(DAY(RC[-1]))=1,""0""&TEXT(DAY(RC[-1]),0),TEXT(DAY(RC[-1]),0))"
Target.Offset(, 2).Value = "=IF(LEN(MONTH(RC[-2]))=1,""0""&TEXT(MONTH(RC[-2]),0),TEXT(MONTH(RC[-2]),0))"
Target.Offset(, 3).Value = "=RIGHT(TEXT(YEAR(RC[-3]),0),2)"
Target.Offset(, 4).Value = "=RC[-3]&RC[-2]&RC[-1]"
Else
Target.Offset(, 1) = Empty
Target.Offset(, 2) = Empty
Target.Offset(, 3) = Empty
Target.Offset(, 4) = Empty
Next
End If
End If
End If
End Sub
[/code][/QUOTE]

Mình thêm như vầy nhưng vẫn không được bạn chỉ them cho mình với.
Xin cảm ơn bạn.

 

[phulien1902]

[QUOTE="
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Clls As Range
If Target.Column = 5 Then
If Target.Rows.Count = 1 Then
For Each Clls In Target
If Target <> Empty Then
Target.Offset(, 1).Value = "=IF(LEN(DAY(RC[-1]))=1,""0""&TEXT(DAY(RC[-1]),0),TEXT(DAY(RC[-1]),0))"
Target.Offset(, 2).Value = "=IF(LEN(MONTH(RC[-2]))=1,""0""&TEXT(MONTH(RC[-2]),0),TEXT(MONTH(RC[-2]),0))"
Target.Offset(, 3).Value = "=RIGHT(TEXT(YEAR(RC[-3]),0),2)"
Target.Offset(, 4).Value = "=RC[-3]&RC[-2]&RC[-1]"
Else
Target.Offset(, 1) = Empty
Target.Offset(, 2) = Empty
Target.Offset(, 3) = Empty
Target.Offset(, 4) = Empty
Next
End If
End If
End If
End Sub
[/code]

Mình thêm như vầy nhưng vẫn không được bạn chỉ them cho mình với.
Xin cảm ơn bạn.[/QUOTE]
Có thể làm cách khác:
+ Code Sheet:

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Address = "$E$2" Then
        abc
    End If
End Sub
+ Code Module:
[php]
Sub abc()
    With Range("F2:F" & Cells(Rows.Count, 5).End(xlUp).Row)
        .Formula = "=IF(LEN(DAY(RC[-1]))=1,""0""&TEXT(DAY(RC[-1]),0),TEXT(DAY(RC[-1]),0))"
        .Offset(, 1) = "=IF(LEN(MONTH(RC[-2]))=1,""0""&TEXT(MONTH(RC[-2]),0),TEXT(MONTH(RC[-2]),0))"
        .Offset(, 2) = "=RIGHT(TEXT(YEAR(RC[-3]),0),2)"
        .Offset(, 3) = "=RC[-3]&RC[-2]&RC[-1]"
    End With
End Sub

[/php]

 

[huongmuine]

Mình thêm như vầy nhưng vẫn không được bạn chỉ them cho mình với.
Xin cảm ơn bạn.

Có thể làm cách khác:
+ Code Sheet:

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Address = "$E$2" Then
        abc
    End If
End Sub
+ Code Module:
[php]
Sub abc()
    With Range("F2:F" & Cells(Rows.Count, 5).End(xlUp).Row)
        .Formula = "=IF(LEN(DAY(RC[-1]))=1,""0""&TEXT(DAY(RC[-1]),0),TEXT(DAY(RC[-1]),0))"
        .Offset(, 1) = "=IF(LEN(MONTH(RC[-2]))=1,""0""&TEXT(MONTH(RC[-2]),0),TEXT(MONTH(RC[-2]),0))"
        .Offset(, 2) = "=RIGHT(TEXT(YEAR(RC[-3]),0),2)"
        .Offset(, 3) = "=RC[-3]&RC[-2]&RC[-1]"
    End With
End Sub

[/php][/QUOTE]
Code này chỉ thực hiện được ở dòng đầu còn các dòng tiếp theo không chạy được.
Cảm ơn bạn đã giúp mình.

 

[phulien1902]

Có thể làm cách khác:
+ Code Sheet:

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Address = "$E$2" Then
        abc
    End If
End Sub
+ Code Module:
[php]
Sub abc()
    With Range("F2:F" & Cells(Rows.Count, 5).End(xlUp).Row)
        .Formula = "=IF(LEN(DAY(RC[-1]))=1,""0""&TEXT(DAY(RC[-1]),0),TEXT(DAY(RC[-1]),0))"
        .Offset(, 1) = "=IF(LEN(MONTH(RC[-2]))=1,""0""&TEXT(MONTH(RC[-2]),0),TEXT(MONTH(RC[-2]),0))"
        .Offset(, 2) = "=RIGHT(TEXT(YEAR(RC[-3]),0),2)"
        .Offset(, 3) = "=RC[-3]&RC[-2]&RC[-1]"
    End With
End Sub

[/php]

Code này chỉ thực hiện được ở dòng đầu còn các dòng tiếp theo không chạy được.
Cảm ơn bạn đã giúp mình.[/QUOTE]
Bạn cứ hay đùa, thử lại lần nữa đi bạn nhé.

 

[huongmuine]

Code này chỉ thực hiện được ở dòng đầu còn các dòng tiếp theo không chạy được.
Cảm ơn bạn đã giúp mình.

Bạn cứ hay đùa, thử lại lần nữa đi bạn nhé.[/QUOTE]
Code này chỉ chạy khi nhập dự liệu vào ô E2.
Do mình copy vào nên code không chạy.
Cảm ơn bạn đã giúp đỡ.
Chúc bạn một ngày vui vẻ.

 

[huongmuine]

Xem lại cú pháp...: chỗ tôi tô màu. Thì biết tại sao???

Cảm ơn bạn đã quan tâm và giúp đỡ.
Chúc bạn một ngày vui vẻ

 

[Ba Tê]

Code này chỉ thực hiện được ở dòng đầu còn các dòng tiếp theo không chạy được.

Bạn Format 4 cột F: I kiểu Text rồi thử chạy Sub này xem sao:

Private Sub Worksheet_Change(ByVal Target As Range)
Dim Cll As Range
If Target.Column = 5 Then
    If Target.Columns.Count = 1 Then
        For Each Cll In Target
            With Cll
                If .Value <> Empty Then
                    .Offset(, 1) = Format(Cll, "dd")
                    .Offset(, 2).Value = Format(Cll, "mm")
                    .Offset(, 3).Value = Format(Cll, "yy")
                    .Offset(, 4).Value = Format(Cll, "ddmmyy")
                Else
                    .Offset(, 1).Resize(, 4).ClearContents
                End If
            End With
        Next Cll
    End If
End If
End Sub

 

[huongmuine]

Bạn Format 4 cột D:F kiểu Text rồi thử chạy Sub này xem sao:

Private Sub Worksheet_Change(ByVal Target As Range)
Dim Cll As Range
If Target.Column = 5 Then
    If Target.Columns.Count = 1 Then
        For Each Cll In Target
            With Cll
                If .Value <> Empty Then
                    .Offset(, 1) = Format(Cll, "dd")
                    .Offset(, 2).Value = Format(Cll, "mm")
                    .Offset(, 3).Value = Year(Cll)
                    .Offset(, 4).Value = Format(Cll, "ddmmyy")
                Else
                    .Offset(, 1).Resize(, 4).ClearContents
                End If
            End With
        Next Cll
    End If
End If
End Sub

Cảm ơn Thầy đã giúp.
Chúc Thầy một ngày nhiều niềm vui.

 

[Ba Tê]

Cảm ơn Thầy đã giúp.
Chúc Thầy một ngày nhiều niềm vui.

Có nhầm lẫn địa chỉ cột, đã chỉnh lại ở bài trên.
Hoặc thay bằng Sub này, có bẫy lỗi khi nhập "chuỗi ba khơi" vào cột E không phải là Date.

Spoiler: GPE

Private Sub Worksheet_Change(ByVal Target As Range)
Dim Cll As Range, Tem As Date
If Target.Column = 5 Then
    If Target.Columns.Count = 1 Then
        For Each Cll In Target
            With Cll
                .Offset(, 1).Resize(, 4).ClearContents
                If .Value <> Empty Then
                    If IsDate(.Value) Then
                        Tem = .Value
                        .Offset(, 1) = Format(Tem, "dd")
                        .Offset(, 2) = Format(Tem, "mm")
                        .Offset(, 3) = Format(Tem, "yy")
                        .Offset(, 4) = Format(Tem, "ddmmyy")
                    End If
                End If
            End With
        Next Cll
    End If
End If
End Sub

 

[truongvu317]

Bạn Format 4 cột F: I kiểu Text rồi thử chạy Sub này xem sao:

Private Sub Worksheet_Change(ByVal Target As Range)
Dim Cll As Range
If Target.Column = 5 Then
    If Target.Columns.Count = 1 Then
        For Each Cll In Target
            With Cll
                If .Value <> Empty Then
                    .Offset(, 1) = Format(Cll, "dd")
                    .Offset(, 2).Value = Format(Cll, "mm")
                    .Offset(, 3).Value = Format(Cll, "yy")
                    .Offset(, 4).Value = Format(Cll, "ddmmyy")
                Else
                    .Offset(, 1).Resize(, 4).ClearContents
                End If
            End With
        Next Cll
    End If
End If
End Sub

Code này không chạy sai trước thì cũng chạy sai sau, hãy cùng nhau đợi đến ngày nó chạy sai đi.

 

[phulien1902]

Code này không chạy sai trước thì cũng chạy sai sau, hãy cùng nhau đợi đến ngày nó chạy sai đi.

Bạn muốn nói đến việc định dạng trong cột E?

 

[cuong.vp.nuce]

VBA:
Cho mình hỏi mình có 1 ô A1 dạng text. mình gán ô B2 = A1.
Mình muốn viết hàm code vba lấy giá trị "B2" mà ra được giá trị text của ô A1 được không.
Các bạn giúp mình.

 

[phulien1902]

VBA:
Cho mình hỏi mình có 1 ô A1 dạng text. mình gán ô B2 = A1.
Mình muốn viết hàm code vba lấy giá trị "B2" mà ra được giá trị text của ô A1 được không.
Các bạn giúp mình.

Bạn thử:

    [a1].Copy
    [b2].PasteSpecial (xlPasteValues)
    [b2].PasteSpecial (xlPasteFormats)

 

[ndu96081631]

VBA:
Cho mình hỏi mình có 1 ô A1 dạng text. mình gán ô B2 = A1.
Mình muốn viết hàm code vba lấy giá trị "B2" mà ra được giá trị text của ô A1 được không.
Các bạn giúp mình.

Excel có sẵn hàm này rồi, không cần vba gì đâu.
=INDIRECT("B2") chính là công thức bạn cần

 

[truelove0310]

Private Sub Worksheet_Activate()

    Dim Rng As Range

    Application.ScreenUpdating = False

    For Each Rng In [a6:a10]

        Rng.EntireRow.Hidden = Rng.Value = "0"

    Next Rng

End Sub

Ai giúp mình đoạn code trên với.
với [a6:a10] thì nó hoạt động ok rồi. giờ mình muốn thêm [c26:c36] hoặc thêm nhiều hơn nữa thì làm thế nào ạ.
Mình thử để [a6:c36] thì nó chỉ ẩn hiện [c26:c36] còn [a6:a10] nó không ẩn hiện được được.
Mình cảm ơn trước nhé

 

[ChanhTQ@]

với [a6:a10] thì nó hoạt động ok rồi. giờ mình muốn thêm [c26:c36] hoặc thêm nhiều hơn nữa thì làm thế nào ạ.
Mình thử để [a6:c36] thì nó chỉ ẩn hiện [c26:c36] còn [a6:a10] nó không ẩn hiện được được.
Mình cảm ơn trước nhé

Duyệt trong 1 cột, thì ô nào thỏa (ĐK) thì cả hàng bị ẩn đi (hay hiện ra)
Duyệt tất thẩy các ô trong ba cột, thì kết quả ẩn hiện sẽ theo ô của cột cuối (là cột 'C' của bạn)
Bảo sao nó làm vậy;
Giờ bạn muốn nó làm khác thì cần nói rõ điều kiện để ẩn hàng khi duyệt lần lượt 3 ô trong hàng đó là sao?

 

[truelove0310]

Duyệt trong 1 cột, thì ô nào thỏa (ĐK) thì cả hàng bị ẩn đi (hay hiện ra)
Duyệt tất thẩy các ô trong ba cột, thì kết quả ẩn hiện sẽ theo ô của cột cuối (là cột 'C' của bạn)
Bảo sao nó làm vậy;
Giờ bạn muốn nó làm khác thì cần nói rõ điều kiện để ẩn hàng khi duyệt lần lượt 3 ô trong hàng đó là sao?

Duyệt trong 1 cột, thì ô nào thỏa (ĐK) thì cả hàng bị ẩn đi (hay hiện ra)
Duyệt tất thẩy các ô trong ba cột, thì kết quả ẩn hiện sẽ theo ô của cột cuối (là cột 'C' của bạn)
Bảo sao nó làm vậy;
Giờ bạn muốn nó làm khác thì cần nói rõ điều kiện để ẩn hàng khi duyệt lần lượt 3 ô trong hàng đó là sao?

điều kiện duyệt là giá trị "0" đó bạn.
Mình có 1 bảng có các ô [a6:a10] và [c26:c36] có giá trị độc lập. giờ mình muốn ô nào có giá trị "0" thì ẩn đi ô nào có giá trị thì hiện ra.

 

[HieuCD]

Private Sub Worksheet_Activate()

    Dim Rng As Range

    Application.ScreenUpdating = False

    For Each Rng In [a6:a10]

        Rng.EntireRow.Hidden = Rng.Value = "0"

    Next Rng

End Sub

Ai giúp mình đoạn code trên với.
với [a6:a10] thì nó hoạt động ok rồi. giờ mình muốn thêm [c26:c36] hoặc thêm nhiều hơn nữa thì làm thế nào ạ.
Mình thử để [a6:c36] thì nó chỉ ẩn hiện [c26:c36] còn [a6:a10] nó không ẩn hiện được được.
Mình cảm ơn trước nhé

Bạn dùng thử hàm Union(Range1,Range2,Range3,...)