Chuyên mục xử lý, gỡ rối code VBA (2 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

 

[ndhmoney686]

Bạn xem code này rồi tùy biến cho côn việc của bạn xem sao:

Public Sub EPG()
Dim I As Long
For I = 9 To 15 Step 3
    Cells(11, I).Resize(10).FormulaR1C1 = Cells(10, I).FormulaR1C1
    Cells(11, I).Resize(10).Value = Cells(11, I).Resize(10).Value
Next I
End Sub

Cám ơn Anh Ba Tê! Em xin phép tập dịch code, và hỏi một số chỗ chưa hiểu. Mong A/C giúp đỡ.

Dim I As Long
For I = 9 To 15 Step 3 'Cho I chạy từ cột 9 tới 15. Step là khoảng cách của các cột là 3 thì chạy code copy paste. Nhưng nếu trường hợp khoảng cách ko đều là 3 cột. Thì mình phải sửa code như thế nào để chạy được nhiều trường hợp Anh nhỉ?
Cells(11, I).Resize(10).FormulaR1C1 = Cells(10, I).FormulaR1C1
Cells(11, I).Resize(10).Value = Cells(11, I).Resize(10).Value
Next I
End Sub

 

[Ba Tê]

Cám ơn Anh Ba Tê! Em xin phép tập dịch code, và hỏi một số chỗ chưa hiểu. Mong A/C giúp đỡ.

Dim I As Long
For I = 9 To 15 Step 3 'Cho I chạy từ cột 9 tới 15. Step là khoảng cách của các cột là 3 thì chạy code copy paste. Nhưng nếu trường hợp khoảng cách ko đều là 3 cột. Thì mình phải sửa code như thế nào để chạy được nhiều trường hợp Anh nhỉ?
Cells(11, I).Resize(10).FormulaR1C1 = Cells(10, I).FormulaR1C1
Cells(11, I).Resize(10).Value = Cells(11, I).Resize(10).Value
Next I
End Sub

Tạo 1 mảng khai báo các cột cần copy.
Tạo 1 biến khai báo số dòng cần copy.
Tùy nghi sử dụng:

Public Sub EPG()
Dim I As Long, J As Long, K As Long, Arr
Arr = Array(9, 12, 15) ' Cac cot can copy cong thuc'
K = 10 'So dong can copy cong thuc'
For I = 0 To UBound(Arr)
    J = Arr(I)
    Cells(11, J).Resize(K).FormulaR1C1 = Cells(10, J).FormulaR1C1
    Cells(11, J).Resize(K).Value = Cells(11, J).Resize(K).Value
Next I
End Sub

 

[ndhmoney686]

Lúc sáng do đọc không ky bài của bạn, nên nghĩ yêu cầu của bạn là đánh chết số.
Vậy bài toán của bạn là: FillDown Formula và đánh chết số.
Có thể có vài cách, nhưng tôi thấy cách của bạn HieuCD là ngắn gọn, tuy nhiên tôi mượn Code của bạn ấy sửa lại 1 chút như sau:

Sub CopyAndPasteFull()
Dim j As Integer, cot As Variant
cot = Array("I", "L", "O")
For j = 0 To 2 
   Sheet1.Cells(10, cot(j)).Copy Sheet1.Cells(11, cot(j)).Resize(10)
    Sheet1.Cells(10, cot(j)).Resize(10).Value = Sheet1.Cells(10, cot(j)).Resize(10).Value
Next j
End Sub

Bạn ơi cho mình hỏi chút
For j=0 to 2 'dịch đoạn code này giúp mình với. Cám ơn Bạn!

 

[ndhmoney686]

Tạo 1 mảng khai báo các cột cần copy.
Tạo 1 biến khai báo số dòng cần copy.
Tùy nghi sử dụng:

Public Sub EPG()
Dim I As Long, J As Long, K As Long, Arr
Arr = Array(9, 12, 15) ' Cac cot can copy cong thuc'
K = 10 'So dong can copy cong thuc'
For I = 0 To UBound(Arr)
    J = Arr(I)
    Cells(11, J).Resize(K).FormulaR1C1 = Cells(10, J).FormulaR1C1
    Cells(11, J).Resize(K).Value = Cells(11, J).Resize(K).Value
Next I
End Sub

Dạ vâng. Em cám ơn Anh Ba Te!
Em đang bước đầu đến với VBA, nên nhiều cái chưa biết. Ko biết mà ko giám hỏi thì mãi mãi ko biết được. Nên Em Mong các A/C giúp đỡ.
Cảm ơn GPE, Cảm ơn A/C rất nhiều!

 

[phulien1902]

Bạn ơi cho mình hỏi chút
For j=0 to 2 'dịch đoạn code này giúp mình với. Cám ơn Bạn!

Nghĩa là thế này:
+Với j=0, tương ứng với cột I
+Với j=1, tương ứng với cột L
+Với j=2, tương ứng với cột O
Vậy thôi.

 

[ndhmoney686]

Nghĩa là thế này:
+Với j=0, tương ứng với cột I
+Với j=1, tương ứng với cột L
+Với j=2, tương ứng với cột O
Vậy thôi.

Cám ơn bạn phulien1902!
Thế mà lúc trưa nghĩ mãi chẳng ra.

 

[thangteo]

Nhờ các anh vào đây giúp đỡ em chỉnh sửa và gỡ rối VBA giúp em với ạ. Em xin chân thành cảm ơn!
http://www.giaiphapexcel.com/forum/...ấu-võ-thuật-trên-máy-tính&p=758290#post758290

 

[xuantam1991]

Giúp mình tạo button Stop vòng lặp ontime này với..

Mình thử chạy code theo thời gian để hiển thị thời gian.
Nhưng không biết làm thế nào để stop lại.
Anh chị chỉ giúp mình code stop với.!

Sub my_onTime()   
 Application.OnTime Now + TimeValue("00:00:1"), "my_Procedure"
End Sub

Sub my_Procedure()   
 Range("A1") = Format(Now(), "yyyy mmm d, hh:mm:ss")    
my_onTime
End Sub

 

[befaint]

Mình thử chạy code theo thời gian để hiển thị thời gian.
Nhưng không biết làm thế nào để stop lại.
Anh chị chỉ giúp mình code stop với.!

Sub my_onTime()   
 Application.OnTime Now + TimeValue("00:00:1"), "my_Procedure"
End Sub

Sub my_Procedure()   
 Range("A1") = Format(Now(), "yyyy mmm d, hh:mm:ss")    
my_onTime
End Sub

Chép vào một module:

Public T As Double
'-------
Sub my_onTime()
    T = Now + TimeValue("0:00:01")
    Application.OnTime EarliestTime:=T, Procedure:="my_Procedure", Schedule:=True
End Sub
'--------
Sub sStop() 'Assign cho nút Stop.
    On Error Resume Next
    Application.OnTime EarliestTime:=T, Procedure:="my_Procedure", Schedule:=False
End Sub
'--------
Sub my_Procedure()
    Sheet1.Range("A1") = Format(Now(), "yyyy mmm d, hh:mm:ss")
    my_onTime
End Su

Chép vào ThisWorkbook:

Private Sub Workbook_BeforeClose(Cancel As Boolean)
sStop
End Sub

 

[thangteo]

Em xin mạn phép gửi nội dung này sang bên chuyên mục này để nhờ các anh sửa giúp:
------------------------
Sau khi em test thử file của anh huuthang_bd (dưới file đính kèm) thì có một số vấn đề sau ạ, và mong các anh ai có thời gian thì chỉnh sửa code giúp em với:
1. Lỗi: Thời gian nghỉ giữa 2 Hiệp khi đang chạy mà nhấn Enter thì lại chạy lại từ đầu như kiểu reset ấy ạ. Lỡ may mà nhấn Enter phát thì thời gian nhỉ lại chạy dài thêm mất.
2. Thêm: một số nút nhấn trực tiếp trên bảng điểm như hình dưới ạ:
- 2 nút cộng và trừ ở mục Nhắc nhở. Phần này sẽ bỏ phím tắt 5 và 0 đi ạ, thay vào đó sẽ nhấn trực tiếp trên bảng chấm điểm. Mỗi lần nhấn là cộng là 1 lần nhắc nhở, nút trừ để phòng khi số lần nhắc nhở bị nhầm và cũng trừ đi 1. Luật nhắc nhở vẫn vậy: 3 lần nhắc nhở tương đương 1 lần cảnh cáo và trừ 1 điểm, 6 lần nhắc nhở tương đương 2 lần cảnh cáo trừ 2 điểm, 9 lần nhắc nhở tương đương 3 lần cảnh cáo trừ 3 điểm và truất quyền thi đấu.
- 2 nút cộng trừ ở mục Điểm. Phần này để cộng hoặc trừ điểm VĐV khi trọng tài chính quyết định, mỗi lần nhấn tương đương cộng 1 điểm hoặc trừ 1 điểm, và cũng để phòng khi số điểm lớn được chỉnh sửa lại cho chính xác theo quyết định trọng tài chính.


- Phím Enter để bắt đầu trận đấu, nhờ các anh thêm phím "dấu cách" để dừng hoặc tiếp tục trận đấu khi trận đấu đang diễn ra ạ.
3. Thay đổi các phím tắt bấm điểm cho VĐV:
- "Như hiện tại thì hình dung tay cầm bấm nút có 2 nút: khi VĐV xanh hoặc đỏ được 1 điểm thì trọng tài bấm nút xanh hoặc đỏ 1 lần, khi được 2 điểm thì bấm đúp nút xanh hoặc đỏ 2 lần."
- Bây giờ thay đổi tay cầm bấm nút có 4 nút như hình thế này:

Mô tả:
- Mỗi tay cầm có 2 nút xanh và 2 nút đỏ. Xanh có: một nút 1 điểm và 1 nút 2 điểm. Đỏ có: 1 nút 1 điểm và 1 nút 2 điểm => Tổng 16 nút bấm cho 4 tay cầm.
- Gán vào các phím tắt trên bàn phím như hình trên:
+ Tay cầm 1: Đỏ: 1 điểm = phím 0, 2 điểm = phím 1. Xanh: 1 điểm = phím 2, 2 điểm = phím 3.
+ Tay cầm 2: Đỏ: 1 điểm = phím 4, 2 điểm = phím 5. Xanh: 1 điểm = phím 6, 2 điểm = phím 7.
+ Tay cầm 3: Đỏ: 1 điểm = phím 8, 2 điểm = phím 9. Xanh: 1 điểm = phím F1, 2 điểm = phím F2.
+ Tay cầm 4: Đỏ: 1 điểm = phím F3, 2 điểm = phím F4. Xanh: 1 điểm = phím F5, 2 điểm = phím F6.
- Việc thêm nút ở tay cầm và gán tất cả các nút vào phím tắt trên bàn phím để thay thế việc nhấn đúp 2 lần khi cho 2 điểm, tránh trường hợp nhấn đúp không thành công.
- Vấn đề 4 ô: 1, 2, 3, 4 ở dọc 2 bên điểm lớn vẫn sáng khi trọng tài bấm nút 1 điểm hoặc 2 điểm ạ. Vấn đề này để xác định trọng tài nào nhấn nút và trọng tài nào không nhấn nút ạ.
--------------------
Vì em không hiểu gì về code VBA cả nên rất mong nhận được sự giúp đỡ của các anh. Cảm ơn ạ!

 

[ndhmoney686]

Tạo 1 mảng khai báo các cột cần copy.
Tạo 1 biến khai báo số dòng cần copy.
Tùy nghi sử dụng:

Public Sub EPG()
Dim I As Long, J As Long, K As Long, Arr
Arr = Array(9, 12, 15) ' Cac cot can copy cong thuc'
K = 10 'So dong can copy cong thuc'
For I = 0 To UBound(Arr)
    J = Arr(I)
    Cells(11, J).Resize(K).FormulaR1C1 = Cells(10, J).FormulaR1C1
    Cells(11, J).Resize(K).Value = Cells(11, J).Resize(K).Value
Next I
End Sub

Em muốn bổ sung thêm thông tin chỉ định sheet cần thực hiện vào trong code trên. Để code chạy đúng sheet mình cần. Mọng A/C và các bạn giúp đỡ.

 

[ndhmoney686]

PHP Code:
Public Sub EPG()
Dim I As Long, J As Long, K As Long, Arr
Arr = Array(9, 12, 15) ' Cac cot can copy cong thuc'
K = 10 'So dong can copy cong thuc'
For I = 0 To UBound(Arr)
J = Arr(I)
Cells(11, J).Resize(K).FormulaR1C1 = Cells(10, J).FormulaR1C1
Cells(11, J).Resize(K).Value = Cells(11, J).Resize(K).Value
Next I
End Sub
Em muốn bổ sung thêm thông tin chỉ định sheet cần thực hiện vào trong code trên. Để code chạy đúng sheet mình cần. Mọng A/C và các bạn giúp đỡ.

Em cho thêm tên sheet vào như này code đã chạy được. Trong trường hợp button ở sheet khác quên ko sửa đường dẫn code, thì nó chỉ chạy ở đúng sheet mình đã mặc định.

PHP Code:
Public Sub EPG()
Dim I As Long, J As Long, K As Long, Arr
Arr = Array(9, 12, 15)
K = 10
For I = 0 To UBound(Arr)
J = Arr(I)
Sheet1.Cells(11, J).Resize(K).FormulaR1C1 = Sheet1.Cells(10, J).FormulaR1C1
Sheet1.Cells(11, J).Resize(K).Value = Sheet1.Cells(11, J).Resize(K).Value
Next I
End Sub

 

[xuantam1991]

Đánh tiếng việt trong textbox và label

Chào mọi người.
Mình làm hộp thoại chat nhưng bị lỗi font khi đánh tiếng việt.
Mong mọi người sửa giùm..!

Private Sub CommandButton1_Click()Dim Text, Data, file As String
Dim fileNo As Integer


file = "C:\text.csv"
' Luu text len server
Text = TextBox1.Value
Open file For Output As #1
Print #1, Text
Close #1
TextBox1.Value = ""


' print ra man hinh
fileNo = FreeFile
Open file For Input As #fileNo
Data = Input$(LOF(fileNo), fileNo)
Close #fileNo
Label1.Caption = Data
TextBox1.SetFocus
End Sub

 

[doveandrose]

Chào mọi người.
Mình làm hộp thoại chat nhưng bị lỗi font khi đánh tiếng việt.
Mong mọi người sửa giùm..!

Private Sub CommandButton1_Click()Dim Text, Data, file As String
Dim fileNo As Integer


file = "C:\text.csv"
' Luu text len server
Text = TextBox1.Value
Open file For Output As #1
Print #1, Text
Close #1
TextBox1.Value = ""


' print ra man hinh
fileNo = FreeFile
Open file For Input As #fileNo
Data = Input$(LOF(fileNo), fileNo)
Close #fileNo
Label1.Caption = Data
TextBox1.SetFocus
End Sub

đọc file tiếng Việt

Public Function ReadText(ByVal filename As String)
With CreateObject("ADODB.Stream")
    .Open
    .Type = 2
    .Charset = "UTF-8"
    .LoadFromFile filename
    ReadText = .ReadText
    .Close
End With
End Function

ghi file tiếng Việt

Public Sub SaveFile(filename As String, content As String)
With CreateObject("ADODB.Stream")
    .Open
    .Type = 2
    .Charset = "UTF-8"
    .WriteText content
    .SaveToFile filename, 2
    .Close
End With
End Sub

 

[maxft2911]

e chào mọi người, mọi người có thể hỗ trợ e vấn đề ở topic này được ko : http://www.giaiphapexcel.com/forum/...-mở-file-excel-được-đính-kèm-trong-file-PDF-!
p/s: mong ad thông cảm vì sự bất tiện này

 

[xuantam1991]

đọc file tiếng Việt

Public Function ReadText(ByVal filename As String)
With CreateObject("ADODB.Stream")
    .Open
    .Type = 2
    .Charset = "UTF-8"
    .LoadFromFile filename
    ReadText = .ReadText
    .Close
End With
End Function

ghi file tiếng Việt

Public Sub SaveFile(filename As String, content As String)
With CreateObject("ADODB.Stream")
    .Open
    .Type = 2
    .Charset = "UTF-8"
    .WriteText content
    .SaveToFile filename, 2
    .Close
End With
End Sub

Cảm ơn bạn nhiều nhé.!

 

[tueyennhi]

Cho em hỏi code sau:

Option Explicit

Public Sub CONG_OVT_new()
Dim Dic As Object, Col As Object, Ws As Worksheet, Tem As String, Rws As Long
Dim sArr(), dArr(1 To 5000, 1 To 38), I As Long, J As Long, K As Long, C As Long
Set Dic = CreateObject("Scripting.Dictionary")
Set Col = CreateObject("Scripting.Dictionary")
With Sheets("T12.2016")
sArr = .Range("b7").Resize(, 38).Value
For J = 1 To 38
If sArr(1, J) <> Empty Then
If IsDate(sArr(1, J)) Then Col.Item(Day(sArr(1, J))) = J
End If
Next J
End With
For Each Ws In Worksheets
If Ws.Name <> "MAU" And Ws.Name <> "Reporst all 12 total" And Ws.Name <> "REPORT" And Ws.Name <> "T12.2016.ovt" And Ws.Name <> "T12.2016" And Ws.Name <> "Check" Then
C = Col.Item(Val(Ws.Name))
sArr = Ws.Range("C9", Ws.Range("C9").End(xlDown)).Resize(, 37).Value
For I = 1 To UBound(sArr)
Tem = sArr(I, 1)
If Not Dic.Exists(Tem) Then
K = K + 1
Dic.Add Tem, K
dArr(K, 1) = sArr(I, 1)
End If
Rws = Dic.Item(Tem)
dArr(Rws, C) = sArr(I, 20)

Next I
End If
Next Ws
Sheets("T12.2016").Range("b8").Resize(K, 36) = dArr
Set Dic = Nothing
Set Col = Nothing
End Sub

Ở dòng lệnh cuối copy mảng vào Sheets("T12.2016").Range("b8").Resize(K, 36) = dArr

Trường hợp nếu Em tách Sheets("T12.2016") thành riêng một file có tên là Report, tên sheet vẫn không đổi là "T12.2016" thì em phải sửa câu lệnh như thế nào để sau khi tổng hợp số liệu xong sẽ chuyển dữ liệu mảng dArr vào file Report này.

Em cảm ơn.

 

[befaint]

Cho em hỏi code sau:
Ở dòng lệnh cuối copy mảng vào Sheets("T12.2016").Range("b8").Resize(K, 36) = dArr
Bây giờ giả sử em muốn tách sheet trên thành một file riêng biệt thì câu lệnh để gán mảng vào file ấy phải thay đổi như thế nào ạ? Mọi thứ giữ nguyên chỉ có thay đổi là di rời sheet thành một file khác.

Em cảm ơn.

Tách sheet/ Di rời thì dùng lệnh copy/move sheet.
Có vẻ yêu cầu không phải thế.
Dán kết quả mảng dArr vào một sheet của 1 workbook (file excel) khác thì:
Gọi workbook đó lên rồi gán dArr vào sheet chỉ định.

 

[tueyennhi]

Tách sheet/ Di rời thì dùng lệnh copy/move sheet.
Có vẻ yêu cầu không phải thế.
Dán kết quả mảng dArr vào một sheet của 1 workbook (file excel) khác thì:
Gọi workbook đó lên rồi gán dArr vào sheet chỉ định.

Mình sửa như thế này mà không được nhỉ?

Application.Workbooks(“T12.2016”).Worksheets( “T12.2016”).Range("b8").Resize(K, 36) = dArr

 

[befaint]

Mình sửa như thế này mà không được nhỉ?

Trước tiên, bạn cần sửa lại yêu cầu của bạn đã. Bạn biểu đạt làm sao để người khác hiểu trúng yêu cầu của mình. Tôi mới chỉ là đoán ý theo bài #647.