Chuyên mục xử lý, gỡ rối code VBA

Liên hệ QC
Status
Không mở trả lời sau này.
ndu96081631

ndu96081631

Huyền thoại GPE
Thành viên BQT
Super Moderator
Tham gia
5/6/08
Bài viết
30,703
Được thích
53,930
Sắp xếp theo thời gian sắp xếp theo bầu chọn
doveandrose đã viết:
đọc file tiếng Việt

Mã: 
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
Mã: 
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
Nhấp chuột vào đây để mở rộng...

Cảm ơn bạn nhiều nhé.!
 
Upvote 0
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
Nhấp chuột vào đây để mở rộng...

Ở 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.
 
Lần chỉnh sửa cuối:
Upvote 0
tueyennhi đã viết:
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.
Nhấp chuột vào đây để mở rộng...

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.
 
Upvote 0
befaint đã viết:
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.
Nhấp chuột vào đây để mở rộng...

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
Nhấp chuột vào đây để mở rộng...
 
Upvote 0
befaint đã viết:
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.
Nhấp chuột vào đây để mở rộng...

Befaint đoán đúng ý mính rồi. Ban đầu lệnh để chuyển dữ liệu mảng vào sheet trong chính file đó. Nhưng nếu chuyển dữ liệu mảng đó vào một file khác thì thay đổi như thế nào?
 
Lần chỉnh sửa cuối:
Upvote 0
À được rồi cảm ơn Befaint nhé, hóa ra khi chạy lệnh phải acticve file Gốc (file số 1), mình active file chuyển đến (File số 2) chạy toàn báo lỗi.
 
Upvote 0
Nhờ tối ưu đoạn code paste special

Mình có 1 đoạn code hoàn chỉnh tuy nhiên cần tối ưu nên nhờ các bạn giúp đỡ

======
Sub chay()
Dim dongcuoi1 As Long
Dim dongcuoi2 As Long
dongcuoi1 = Worksheets("0").Range("P" & Rows.Count).End(xlUp).Row
Range("D2:O2").Select
Selection.AutoFill Destination:=Range("D2:O" & dongcuoi1)
Columns("D:F").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _:=False, Transpose:=False
Range([F2], [F1048576].End(xlUp)).Copy [C2]
Range([E2], [E1048576].End(xlUp)).Copy [C1048576].End(xlUp).Offset(1)
Range([D2], [D1048576].End(xlUp)).Copy [C1048576].End(xlUp).Offset(1)
Range([C2], [C1048576].End(xlUp)).RemoveDuplicates Columns:=1
dongcuoi2 = Worksheets("0").Range("C2").End(xlDown).Row
Range("A2:B2").Select
Selection.AutoFill Destination:=Range("A2:B" & dongcuoi2&)
Cells.Select
ActiveWorkbook.Save
Range("A1").Select
Range("A1", Range("A2").End(xlDown)).Select
Selection.Copy
End Sub
======
Ở phần code này(bên dưới):
=====
Columns("D:F").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _:=False, Transpose:=False
Range([F2], [F1048576].End(xlUp)).Copy [C2]
Range([E2], [E1048576].End(xlUp)).Copy [C1048576].End(xlUp).Offset(1)
Range([D2], [D1048576].End(xlUp)).Copy [C1048576].End(xlUp).Offset(1)

=====
Mình đang thực hiện select từ cột D đến cột F sau đó thực hiện Copy Paste Special Values lại rồi mới thực hiện nhập các dữ liệu có ở cột D, cột E, Cột F lại vào chung cột C
mình muốn cái tiến việc này bằng cách bỏ việc phải Copy Paste Special Values ở cột D đến F đi mà thực hiện nhập dữ liệu có ở cột D, E, F vào cột C luôn với việc khi paste sẽ là Paste Special Values
Anh em giúp mình với.
 

File đính kèm

  • test.xlsm
    16.8 KB · Đọc: 3
Upvote 0
thangteo đã viết:
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 ạ!
Nhấp chuột vào đây để mở rộng...

Nhờ các bác giành thời gian hỗ trợ giúp đỡ em với ạ!
 
Upvote 0
DINODRAGON đã viết:
Mình có 1 đoạn code hoàn chỉnh tuy nhiên cần tối ưu nên nhờ các bạn giúp đỡ

======
Sub chay()
Dim dongcuoi1 As Long
Dim dongcuoi2 As Long
dongcuoi1 = Worksheets("0").Range("P" & Rows.Count).End(xlUp).Row
Range("D2:O2").Select
Selection.AutoFill Destination:=Range("D2:O" & dongcuoi1)
Columns("D:F").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _:=False, Transpose:=False
Range([F2], [F1048576].End(xlUp)).Copy [C2]
Range([E2], [E1048576].End(xlUp)).Copy [C1048576].End(xlUp).Offset(1)
Range([D2], [D1048576].End(xlUp)).Copy [C1048576].End(xlUp).Offset(1)
Range([C2], [C1048576].End(xlUp)).RemoveDuplicates Columns:=1
dongcuoi2 = Worksheets("0").Range("C2").End(xlDown).Row
Range("A2:B2").Select
Selection.AutoFill Destination:=Range("A2:B" & dongcuoi2&)
Cells.Select
ActiveWorkbook.Save
Range("A1").Select
Range("A1", Range("A2").End(xlDown)).Select
Selection.Copy
End Sub
======
Ở phần code này(bên dưới):
=====
Columns("D:F").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _:=False, Transpose:=False
Range([F2], [F1048576].End(xlUp)).Copy [C2]
Range([E2], [E1048576].End(xlUp)).Copy [C1048576].End(xlUp).Offset(1)
Range([D2], [D1048576].End(xlUp)).Copy [C1048576].End(xlUp).Offset(1)

=====
Mình đang thực hiện select từ cột D đến cột F sau đó thực hiện Copy Paste Special Values lại rồi mới thực hiện nhập các dữ liệu có ở cột D, cột E, Cột F lại vào chung cột C
mình muốn cái tiến việc này bằng cách bỏ việc phải Copy Paste Special Values ở cột D đến F đi mà thực hiện nhập dữ liệu có ở cột D, E, F vào cột C luôn với việc khi paste sẽ là Paste Special Values
Anh em giúp mình với.
Nhấp chuột vào đây để mở rộng...
Bạn thế bằng đoạn code
Mã: 
[C2].Resize(Range([F2], [F1048576].End(xlUp)).Rows.Count).Value = Range([F2], [F1048576].End(xlUp)).Value
[C1048576].End(xlUp).Offset(1).Resize(Range([E2], [E1048576].End(xlUp)).Rows.Count).Value = Range([E2], [E1048576].End(xlUp)).Value
[C1048576].End(xlUp).Offset(1).Resize(Range([D2], [D1048576].End(xlUp)).Rows.Count).Value = Range([D2], [D1048576].End(xlUp)).Value
 
Upvote 0
Chào các anh (chị) hiện nay em có 1 đoạn mã VBA đã viết (nói chung là chạy tốt) nhưng do số liệu bảng tra quá dài (trên 50000 dòng) nên đoạn code phát huy không hiệu quả.
Chạy rất chậm và bị giật.
Nhờ các anh chị chỉnh lại giúp em đoạn code sau. Em xin chân thành cám ơn

Sub bienban()
On Error Resume Next
Dim sh1 As Worksheet ' Sheet DMCVNT
Dim Rng1 As Range
Dim STT_BBNT As Range
Dim STT_BB As Range
Dim STT_BBCV As Range
Dim VT_DTNT As Range
Dim VT_NDTCV As Range
Dim VT_TCV As Range
Dim VT_TCAD As Range
Dim VT_KTCV As Range
Dim sodongcp As Integer
Dim I As Integer
Dim bb As Integer
Dim SoBienBan As Integer
For bb = 1 To DMCVNT.Range("SoBB") 'So bien ban
Application.Interactive = False
Application.EnableEvents = False
Application.ScreenUpdating = False
Application.Calculation = xlManual
MBBNTNBCV.Copy before:=Sheets(bb)
Range("K5") = bb
'*******Dua so lieu tu bang Danh muc cong viec nghiem thu sang Bien ban nghiem thu ***************
Set STT_BB = Range("K5")
Set VT_DTNT = Sheets(bb).Cells.Find(What:="dtnt", After:=ActiveCell, LookIn:=xlComments, LookAt _
:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False, SearchFormat:=False)
Set VT_TCV = Sheets(bb).Cells.Find(What:="TCV", After:=ActiveCell, LookIn:=xlComments, LookAt _
:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False, SearchFormat:=False)
Set VT_NDTCV = Sheets(bb).Cells.Find(What:="NDKT", After:=ActiveCell, LookIn:=xlComments, LookAt _
:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False, SearchFormat:=False)
Set VT_TCAD = Sheets(bb).Cells.Find(What:="TCAD", After:=ActiveCell, LookIn:=xlComments, LookAt _
:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False, SearchFormat:=False)
Set VT_KTCV = Sheets(bb).Cells.Find(What:="KTCV", After:=ActiveCell, LookIn:=xlComments, LookAt _
:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False, SearchFormat:=False)
Set Rng1 = Range(DMCVNT.[A6], DMCVNT.[A65500].End(xlUp))
Set STT_BBCV = Rng1.Find(STT_BB, , xlFormulas, xlWhole)
If STT_BBCV Is Nothing Then
VT_DTNT.Offset(0, 0).Font.ColorIndex = 3
Else
'Chen dong bien ban
Range(STT_BBCV.Offset(0, 17), STT_BBCV.End(xlDown).Offset(-1, 50)).Copy
VT_DTNT.Offset(1, 0).EntireRow.Insert
Range(STT_BBCV.Offset(0, 17), STT_BBCV.End(xlDown).Offset(-1, 50)).Copy
VT_TCV.Offset(1, 0).EntireRow.Insert
Range(STT_BBCV.Offset(0, 17), STT_BBCV.End(xlDown).Offset(-2, 50)).Copy
VT_TCAD.Offset(1, 0).EntireRow.Insert
Range(STT_BBCV.Offset(0, 17), STT_BBCV.End(xlDown).Offset(-1, 50)).Copy
VT_NDTCV.Offset(1, 0).EntireRow.Insert
'Copy so thu tu
Range(STT_BBCV.Offset(0, 1), STT_BBCV.End(xlDown).Offset(-1, 1)).Copy
VT_DTNT.Offset(1, 0).PasteSpecial (xlPasteValues)
VT_TCAD.Offset(1, 0).PasteSpecial (xlPasteValues)
VT_NDTCV.Offset(1, 0).PasteSpecial (xlPasteValues)
VT_TCV.Offset(1, 0).PasteSpecial (xlPasteValues)
'Ma hieu cong viec
Range(STT_BBCV.Offset(0, 2), STT_BBCV.End(xlDown).Offset(-2, 2)).Copy
VT_TCAD.Offset(1, -2).PasteSpecial (xlPasteValues)
VT_TCAD.Offset(1, 14).PasteSpecial (xlPasteValues)
VT_NDTCV.Offset(1, -3).PasteSpecial (xlPasteValues)
'Copy ten cong viec
Range(STT_BBCV.Offset(0, 3), STT_BBCV.End(xlDown).Offset(-1, 3)).Copy
VT_DTNT.Offset(1, 1).PasteSpecial (xlPasteValues)
VT_TCV.Offset(1, 1).PasteSpecial (xlPasteValues)
VT_NDTCV.Offset(1, 1).PasteSpecial (xlPasteValues)
VT_TCAD.Offset(1, 1).PasteSpecial (xlPasteValues)
'Copy don vi
Range(STT_BBCV.Offset(0, 4), STT_BBCV.End(xlDown).Offset(-1, 4)).Copy
VT_TCV.Offset(1, 8).PasteSpecial (xlPasteValues)
'Khoi luong cong viec
Range(STT_BBCV.Offset(0, 5), STT_BBCV.End(xlDown).Offset(-2, 5)).Copy
VT_TCV.Offset(1, 9).PasteSpecial (xlPasteValues)
Range(STT_BBCV.Offset(0, 6), STT_BBCV.End(xlDown).Offset(-2, 6)).Copy
VT_TCV.Offset(1, 11).PasteSpecial (xlPasteValues)
'Ke bang noi dung kiem tra
Range(VT_NDTCV.Offset(0, 1), VT_TCV.Offset(-3, 12)).Select
End If

'Dien ki hieu nhan biet noi dung kiem tra ten cong viec
For I = 11 To 500
If Cells(I, "A") <> "" Then
Cells(I, "B") = ":" & Cells(I, "A")
End If
Next I
'***** Chen cac noi dung tieu chuan va noi dung kiem tra cong viec ******
' Khai báo
Range("B7").End(xlDown).Select
Dim Sh As Worksheet, Rng As Range, sRng As Range, XX As Range
Set Sh = Workbooks("TCVN.xla").Worksheets("TCNTCV")
Set Rng = Sh.Range(Sh.[C2], Sh.[C65500].End(xlUp))


'Tra du lieu tao bang CMPT
Do Until Selection = ""
Set XX = Selection
Set sRng = Rng.Find(XX, , xlFormulas, xlWhole)
If sRng Is Nothing Then
Selection.Font.ColorIndex = 3
Selection.Offset(1, 0).Select
Selection.EntireRow.Insert
Selection.End(xlDown).Select
Else
Range(sRng.Offset(0, 0), sRng.End(xlDown).Offset(-1, 0)).EntireRow.Copy
Selection.Offset(1, -1).Insert Shift:=xlDown
Selection.ClearContents
Selection.End(xlDown).Select
End If
Loop
Application.CutCopyMode = False
Range("A1").Select
Sheets(bb).Name = "NTNBCV" & bb
'Dinh dang bang bieu
Dim x As Integer
For x = 11 To 500
If Cells(x, "A") <> "" Then
Range(Cells(x, "D"), Cells(x, "P")).Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
End With
With Selection
.HorizontalAlignment = xlCenterAcrossSelection
.VerticalAlignment = xlCenter
.WrapText = True
.MergeCells = False
.Font.Bold = True
.Font.Italic = True
End With
End If
If Cells(x, "R") <> "" Then
Cells(x, "D").Select
With Selection
.HorizontalAlignment = xlRight
.VerticalAlignment = xlCenter
.WrapText = True
'.Font.Bold = True
.Font.Italic = True
End With
Range(Cells(x, "E"), Cells(x, "P")).Select
With Selection
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlCenter
.WrapText = True
.MergeCells = True
'.Font.Bold = True
.Font.Italic = True
End With
End If


'Ke bang khoi luong
Range(VT_TCV.Offset(1, 0), VT_KTCV.Offset(-2, 0)).Select
With Selection
.HorizontalAlignment = xlCenterAcrossSelection
.VerticalAlignment = xlCenter
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlHairline
End With
Selection.NumberFormat = "General"
'Ke chan bang noi dung nghiem thu
Range(VT_TCV.Offset(-4, 0), VT_TCV.Offset(-4, 12)).Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlHairline
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
Range("D1").Select
Next x
'Tao bien ban tiep theo
Next bb
Application.Interactive = True
Application.EnableEvents = True
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Sheets(1).Select
Set STT_BB = Nothing
Set VT_DTNT = Nothing
Set VT_TCV = Nothing
Set VT_NDTCV = Nothing
Set VT_TCAD = Nothing
Set Rng1 = Nothing
Set STT_BBCV = Nothing
Set Sh = Nothing
Set Rng = Nothing
Set XX = Nothing
Set sRng = Nothing
End Sub
 
Upvote 0
Nhờ các anh bổ xung phím "dấu cách" để dừng và tiếp tục thời gian thi đấu với ạ:
----------------------------
Cái này bên Module:
Private Sub DisplayTimer()
Dim i As Long
If Min = 0 And Sec <= 1 Then
Display_Off
SubBeep
iArrTimeInfo = iArrTimeInfo + 1
If iArrTimeInfo <= UBound(ArrTimeInfo, 2) Then
BangDiem.LB_ThoiGian.Caption = ArrTimeInfo(1, iArrTimeInfo) & ":" & Format(ArrTimeInfo(2, iArrTimeInfo), "00")
If Round(iArrTimeInfo Mod 2, 0) = 0 Then
Display_On
Else
BangDiem.LB_Hiep.Caption = ThongTin.Range(Hiep).Value & " " & Round((iArrTimeInfo + 1) / 2, 0)
BangDiem.LB_TrangThai.Caption = ThongTin.Range(SanSang).Value
End If
Else
BangDiem.LB_ThoiGian.Caption = "0:00"
BangDiem.LB_TrangThai.Caption = ThongTin.Range(KetThuc).Value
BangDiem.CB_DangThiDau.Value = False
End If
Exit Sub
ElseIf Sec = 0 And Min > 0 Then
Sec = 59: Min = Min - 1
Else
Sec = Sec - 1
End If
BangDiem.LB_ThoiGian.Caption = Min & ":" & Format(Sec, "00")
End Sub
-------------------------------
Cái này là bên Forms: (đã gán nhấn phím Enter (13) chạy thời gian rồi).
Private Sub TB_NhanTinHieu_KeyUp(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
If Not Me.CB_DangThiDau.Value Then
If KeyCode = 13 Then
If iArrTimeInfo <= UBound(ArrTimeInfo, 2) Then
Me.CB_DangThiDau.Value = True
Display_On
End If
End If
End If
Select Case KeyCode
Case TT1D
Me.LB_TT1_Do.BackColor = BackColor0
Case TT2D
Me.LB_TT2_Do.BackColor = BackColor0
Case TT3D
Me.LB_TT3_Do.BackColor = BackColor0
Case TT4D
Me.LB_TT4_Do.BackColor = BackColor0
Case TT1X
Me.LB_TT1_Xanh.BackColor = BackColor0
Case TT2X
Me.LB_TT2_Xanh.BackColor = BackColor0
Case TT3X
Me.LB_TT3_Xanh.BackColor = BackColor0
Case TT4X
Me.LB_TT4_Xanh.BackColor = BackColor0
Case 27
Unload Me
End Select
KeyCode = 0
End Sub
--------------------------
Em không biết về code VBA nên nếu cần rõ hơn các anh lấy file về xem cho kỹ ở bài #640.
Rất mong các anh bớt chút thời gian giúp đỡ ạ.
 
Lần chỉnh sửa cuối:
Upvote 0
HieuCD đã viết:
Bạn thế bằng đoạn code
Mã: 
[C2].Resize(Range([F2], [F1048576].End(xlUp)).Rows.Count).Value = Range([F2], [F1048576].End(xlUp)).Value
[C1048576].End(xlUp).Offset(1).Resize(Range([E2], [E1048576].End(xlUp)).Rows.Count).Value = Range([E2], [E1048576].End(xlUp)).Value
[C1048576].End(xlUp).Offset(1).Resize(Range([D2], [D1048576].End(xlUp)).Rows.Count).Value = Range([D2], [D1048576].End(xlUp)).Value
Nhấp chuột vào đây để mở rộng...

Mình không thấy nút thank để gửi bạn một Like!. Cám ơn bạn rất nhiều.
 
Upvote 0
Giúp tối ưu thêm lần nữa

Mình muốn tối ưu thêm ở đoạn code này
=======
dongcuoi1 = Worksheets("0").Range("Z" & Rows.Count).End(xlUp).Row
Range("D2:O2").Select
Selection.AutoFill Destination:=Range("D2:O" & dongcuoi1)
=====

mình đang sử dụng số dòng tại cột Z để làm căn cứ cho lệnh autofill ở dưới tuy nhiên mình muốn so sánh thêm giữa 3 cột là cột P, cột U và cột Z, cột nào có số dòng lớn nhất thì sẽ căn cứ vào số dòng của cột đó mà autofill
Bạn giúp mình với


=======================
Sub chay()
Dim dongcuoi1 As Long
Dim dongcuoi2 As Long
dongcuoi1 = Worksheets("0").Range("Z" & Rows.Count).End(xlUp).Row
Range("D2:O2").Select
Selection.AutoFill Destination:=Range("D2:O" & dongcuoi1)
[C2].Resize(Range([F2], [F1048576].End(xlUp)).Rows.Count).Value = Range([F2], [F1048576].End(xlUp)).Value
[C1048576].End(xlUp).Offset(1).Resize(Range([E2], [E1048576].End(xlUp)).Rows.Count).Value = Range([E2], [E1048576].End(xlUp)).Value
[C1048576].End(xlUp).Offset(1).Resize(Range([D2], [D1048576].End(xlUp)).Rows.Count).Value = Range([D2], [D1048576].End(xlUp)).Value
Range([C2], [C1048576].End(xlUp)).RemoveDuplicates Columns:=1
dongcuoi2 = Worksheets("0").Range("C2").End(xlDown).Row
Range("A2:B2").Select
Selection.AutoFill Destination:=Range("A2:B" & dongcuoi2&)
Cells.Select
ActiveWorkbook.Save
Range("A1").Select
Range("A1", Range("A2").End(xlDown)).Select
Selection.Copy
End Sub
 
Upvote 0
DINODRAGON đã viết:
mình đang sử dụng số dòng tại cột Z để làm căn cứ cho lệnh autofill ở dưới tuy nhiên mình muốn so sánh thêm giữa 3 cột là cột P, cột U và cột Z, cột nào có số dòng lớn nhất thì sẽ căn cứ vào số dòng của cột đó mà autofill
Nhấp chuột vào đây để mở rộng...

Mã: 
Dim lr As Long
lr = Worksheets("0").Range("U2:Z2").End(xlDown).Row

p/s: Code thì vui lòng cho vào thẻ
Mã: 
 hoặc [php]

[COLOR=#ffffff]Cái trang này dài quá thể là dài!!!![/COLOR]
 
Upvote 0
Cám ơn bạn
Mình sẽ rút kinh nghiệm lần sau đưa vào thẻ code
Nhưng code bạn đưa ra cho vào nó không chạy được.
 
Upvote 0
Mình đã tự giải được rồi, cám ơn các bạn nhiều
Mã: 
[/COLOR]
Sub chay()
Dim dongcuoi1 As Long
Dim dongcuoi2 As Long
Dim cp As Long
Dim cu As Long
Dim cz As Long
cp = Worksheets("0").Range("P" & Rows.Count).End(xlUp).Row
cu = Worksheets("0").Range("U" & Rows.Count).End(xlUp).Row
cz = Worksheets("0").Range("Z" & Rows.Count).End(xlUp).Row
dongcuoi1 = cp
If dongcuoi1 < cu Then dongcuoi1 = cu
If dongcuoi1 < cz Then dongcuoi1 = cz
Range("D2:O2").Select
Selection.AutoFill Destination:=Range("D2:O" & dongcuoi1)
[C2].Resize(Range([F2], [F1048576].End(xlUp)).Rows.Count).Value = Range([F2], [F1048576].End(xlUp)).Value
[C1048576].End(xlUp).Offset(1).Resize(Range([E2], [E1048576].End(xlUp)).Rows.Count).Value = Range([E2], [E1048576].End(xlUp)).Value
[C1048576].End(xlUp).Offset(1).Resize(Range([D2], [D1048576].End(xlUp)).Rows.Count).Value = Range([D2], [D1048576].End(xlUp)).Value
Range([C2], [C1048576].End(xlUp)).RemoveDuplicates Columns:=1
dongcuoi2 = Worksheets("0").Range("C2").End(xlDown).Row
Range("A2:B2").Select
Selection.AutoFill Destination:=Range("A2:B" & dongcuoi2&)
Cells.Select
ActiveWorkbook.Save
Range("A1").Select
Range("A1", Range("A2").End(xlDown)).Select
Selection.Copy
End Sub
[COLOR=#000000]
 
Upvote 0
Status
Không mở trả lời sau này.
Web KT

Bài viết mới nhất

LuuAnh980
Vấn đề viết tắt trong Diễn Đàn.
    • Thích
Trả lời
6
Đọc
63
senna
senna
senna
  • Question
Xin giúp đỡ tổng hợp dữ liệu từ nhiều file vào 1 file mà không cần mở file
Trả lời
2
Đọc
69
senna
senna
ann266
Kế toán kho F&B
    • Cười
2
Trả lời
21
Đọc
211
ann266
ann266
P
Hướng dẫn giải bài tập excel
Trả lời
2
Đọc
65
VetMini
V
T
Cần bạn viết phần mềm quản lý quán karaoke bằng excel
Trả lời
7
Đọc
162
VetMini
V
Xem thêm…

Facebook

Giaiphapexcel.com

Group

DIỄN ĐÀN GIẢI PHÁP EXCEL Group 1
DIỄN ĐÀN GIẢI PHÁP EXCEL Group 2

Thành viên có số lượng bài viết cao nhất tháng

Thành viên có điểm tương tác cao nhất tháng

Back
Top Bottom