Sửa giúp code vba để Merge và kẻ khung (1 người xem)

Liên hệ QC

Người dùng đang xem chủ đề này

Đang trực tuyến: 1 (Thành viên: 0, Khách: 1)
Thuyanhanoi

Thuyanhanoi

Thành viên thường trực
Tham gia
15/10/12
Bài viết
304
Được thích
154
Nghề nghiệp
Nhân viên
Mình có một đoạn code để lấy dữ liệu một vùng bảng tính bên sheet(DaTa) sang sheet Mau.
Hiện code của mình đã lấy được dữ liệu. Nhưng mình muốn trong code phải Merge và kẻ khung viền(Như sheet Mau mình đã làm) trong file đính kèm.
Mong các bạn sửa giúp mình để code thực hiện được thêm những điều mình đã nói ở trên.
Mã: 
Public Sub Mau_TH()
    Dim i As Long, J As Long, sArr(), dArr(), K As Long, STT As Long
    With Sheets("DaTa")
        sArr = .Range("B12:AO69").Value
    End With
    ReDim dArr(1 To UBound(sArr, 1), 1 To 40)
    For i = 1 To UBound(sArr, 1) Step 2
      'If sArr(i, 2) <> "" Then
        K = K + 1: STT = STT + 1
        dArr(K, 1) = STT
        For J = 2 To 10 ' 38
            dArr(K, J) = sArr(i, J)
            dArr(K + 1, J) = sArr(i + 1, J)
        Next J
            dArr(K, 11) = "AH"
            dArr(K + 1, 11) = "BM"
        For J = 12 To 38
            dArr(K, J) = sArr(i, J)
            dArr(K + 1, J) = sArr(i + 1, J)
        Next J
        If sArr(i, 40) > 0 Then
        dArr(K, 39) = sArr(i, 40)
        End If
      'End If
      K = K + 1
    Next i
    With Sheets("Mau")
        .[A12:AN200].ClearContents
        .[A12].Resize(K, 40).Value = dArr
        .[A12].Resize(K, 38).Borders.LineStyle = xlContinuous
        .[A12].Resize(K, 38).Borders(xlInsideHorizontal).Weight = xlHairline
        .[G12:J200,L12:AL200].ClearContents
        .[A12].Resize(K + 20, 50).Locked = False
        .[A12].Resize(K, 7).Locked = True
        .[AL12].Resize(K, 2).Locked = True
        .[K12].Resize(K, 1).Locked = True
        'ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True, Password:="123"
    End With
End Sub
Xin cảm ơn các bạn đã giúp mình!.
 

File đính kèm

Lần chỉnh sửa cuối:
Sắp xếp theo thời gian sắp xếp theo bầu chọn
Mã: 
Public Sub Mau_TH()
Application.ScreenUpdating = False
'....
        .[K12].Resize(K, 1).Locked = True
        Dim c As Byte
        For c = 1 To 4
            Mege .Range("A12").Offset(0, c - 1).Resize(K, 1)
        Next c
        Mege .Range("H12").Resize(K, 1)
        'ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True, Password:="123"
    End With
Application.ScreenUpdating = True
End Sub
'------------
Sub Mege(rng As Range)
Dim r As Long
If rng.Columns.Count > 1 Then Exit Sub
For r = 1 To rng.Rows.Count Step 2
    rng.Cells(r, 1).Resize(2, 1).MergeCells = True
Next r
End Sub
 
Upvote 0
Cảm ơn Bạn đã giúp mình!.
- Mình làm theo bạn hướng dẫn thì phát sinh như sau:
Mã: 
Public Sub Mau_TH()
Application.ScreenUpdating = False
    Dim i As Long, J As Long, sArr(), dArr(), K As Long, STT As Long
    With Sheets("DaTa")
        sArr = .Range("B12:AO69").Value
    End With
    ReDim dArr(1 To UBound(sArr, 1), 1 To 40)
    For i = 1 To UBound(sArr, 1) Step 2
      'If sArr(i, 2) <> "" Then
        K = K + 1: STT = STT + 1
        dArr(K, 1) = STT
        For J = 2 To 10 ' 38
            dArr(K, J) = sArr(i, J)
            dArr(K + 1, J) = sArr(i + 1, J)
        Next J
            dArr(K, 11) = "AH"
            dArr(K + 1, 11) = "BM"
        For J = 12 To 38
            dArr(K, J) = sArr(i, J)
            dArr(K + 1, J) = sArr(i + 1, J)
        Next J
        If sArr(i, 40) > 0 Then
        dArr(K, 39) = sArr(i, 40)
        End If
      'End If
      K = K + 1
    Next i
    With Sheets("Mau")
        .[A12:AN200].ClearContents
        .[A12].Resize(K, 40).Value = dArr
        .[A12].Resize(K, 38).Borders.LineStyle = xlContinuous
        '.[A12].Resize(K, 38).Borders(xlInsideHorizontal).Weight = xlHairline
        .[G12:J200,L12:AL200].ClearContents
        .[A12].Resize(K + 20, 50).Locked = False
        .[A12].Resize(K, 7).Locked = True
        .[AL12].Resize(K, 2).Locked = True
        .[K12].Resize(K, 1).Locked = True
        .[K12].Resize(K, 1).Locked = True
        Dim c As Byte
        For c = 1 To 4
            Mege .Range("A12").Offset(0, c - 1).Resize(K, 1)
        Next c
        Mege .Range("H12").Resize(K, 1)
        'ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True, Password:="123"
    End With
    Application.ScreenUpdating = True
End Sub


'------------
Sub Mege(rng As Range)
Dim r As Long
If rng.Columns.Count > 1 Then Exit Sub
For r = 1 To rng.Rows.Count Step 2
    rng.Cells(r, 1).Resize(2, 1).MergeCells = True
Next r
End Sub

- Trên Sheet(DaTa) vùng dữ liệu từ cột [H] đến cột [AM] nếu có dữ liệu thì khi chạy code thì không lấy sang được Sheet(Mau): Xin lỗi mình nhầm ý này! (.[G12:J200,L12:AL200].ClearContents)
- Bạn giúp thêm mình một chút nữa là: Giữa 2 dòng có Merge thì kẻ đường mờ "xlHairline" ở giữa với các cột còn lại không Merge

Mình cảm ơn bạn nhiều!.
befaint đã viết:
Mã: 
Public Sub Mau_TH()
Application.ScreenUpdating = False
'....
        .[K12].Resize(K, 1).Locked = True
        Dim c As Byte
        For c = 1 To 4
            Mege .Range("A12").Offset(0, c - 1).Resize(K, 1)
        Next c
        Mege .Range("H12").Resize(K, 1)
        'ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True, Password:="123"
    End With
Application.ScreenUpdating = True
End Sub
'------------
Sub Mege(rng As Range)
Dim r As Long
If rng.Columns.Count > 1 Then Exit Sub
For r = 1 To rng.Rows.Count Step 2
    rng.Cells(r, 1).Resize(2, 1).MergeCells = True
Next r
End Sub
Nhấp chuột vào đây để mở rộng...
 

File đính kèm

Lần chỉnh sửa cuối:
Upvote 0
Thuyanhanoi đã viết:
Giữa 2 dòng có Merge thì kẻ đường mờ "xlHairline" ở giữa với các cột còn lại không Merge
Nhấp chuột vào đây để mở rộng...
Chèn vào dòng '.[A12].Resize(K, 38).Borders(xlInsideHorizontal).Weight = xlHairline
Mã: 
Dim r As Long
For r = 1 To K Step 2
    .[A11].Offset(r, 0).Resize(2, 38).Borders(xlInsideHorizontal).Weight = xlHairline
Next r
Chuyển Dim r và Dim c lên trên đầu
 
Upvote 0
Cảm ơn bạn nhiều!.
- Mình làm theo hương dẫn của bạn thì đã kẻ được khung như ý. Nhưng lại say ra tình huống như sau mong bạn giúp mình với!.
- Lúc trước trong code mình tắt đi dòng này:
Mã: 
ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True, Password:="123"
Nay mình để cho dòng code đó hoạt động thì ở cột [H] Sheet(Mau) mặc dù mình đã để ở chế độ Locked = False nhưng sao nó không được
Mục đích của mình là các cột Từ [A:E] của sheet(Mau) được Locked để khỏi vô tình làm ảnh hưởng tới dữ liệu; Cột [H] của sheet(Mau) code marge mình không muốn Locked vì để nhập dữ liệu vào.
Mong bạn và mọi người xem giúp mình với nhé!. Mình cảm ơn mọi sự giúp đỡ!.
befaint đã viết:
Chèn vào dòng '.[A12].Resize(K, 38).Borders(xlInsideHorizontal).Weight = xlHairline
Mã: 
Dim r As Long
For r = 1 To K Step 2
    .[A11].Offset(r, 0).Resize(2, 38).Borders(xlInsideHorizontal).Weight = xlHairline
Next r
Chuyển Dim r và Dim c lên trên đầu
Nhấp chuột vào đây để mở rộng...
 
Upvote 0
Thuyanhanoi đã viết:
Mã: 
ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True, Password:="123"
Nay mình để cho dòng code đó hoạt động thì ở cột [H] Sheet(Mau) mặc dù mình đã để ở chế độ Locked = False nhưng sao nó không được
Nhấp chuột vào đây để mở rộng...
Thêm dòng:
ActiveSheet.Unprotect Password:="123"
trước dòng:
With Sheets("Mau")
 
Upvote 0
VBA và Merged cells là lửa và dầu.
Hai cái này vọc cùng 1 lúc thì thế nào cũng có lúc bỏng.
 
Upvote 0
befaint đã viết:
Thêm dòng:
ActiveSheet.Unprotect Password:="123"
trước dòng:
With Sheets("Mau")
Nhấp chuột vào đây để mở rộng...
Mình làm theo bạn!.
Mã: 
Public Sub Mau_TH()
Application.ScreenUpdating = False
    Dim i As Long, J As Long, sArr(), dArr(), K As Long, STT As Long
    Dim r As Long, c As Byte
    With Sheets("DaTa")
        sArr = .Range("B12:AO69").Value
    End With
    ReDim dArr(1 To UBound(sArr, 1), 1 To 40)
    For i = 1 To UBound(sArr, 1) Step 2
      'If sArr(i, 2) <> "" Then
        K = K + 1: STT = STT + 1
        dArr(K, 1) = STT
        For J = 2 To 10 ' 38
            dArr(K, J) = sArr(i, J)
            dArr(K + 1, J) = sArr(i + 1, J)
        Next J
            dArr(K, 11) = "AH"
            dArr(K + 1, 11) = "BM"
        For J = 12 To 38
            dArr(K, J) = sArr(i, J)
            dArr(K + 1, J) = sArr(i + 1, J)
        Next J
        If sArr(i, 40) > 0 Then
        dArr(K, 39) = sArr(i, 40)
        End If
      'End If
      K = K + 1
    Next i
    ActiveSheet.Unprotect Password:="123"
    With Sheets("Mau")
        .[A12:AN200].ClearContents
        .[A12].Resize(K, 40).Value = dArr
        .[A12].Resize(K, 38).Borders.LineStyle = xlContinuous
        For r = 1 To K Step 2
            .[A11].Offset(r, 0).Resize(2, 38).Borders(xlInsideHorizontal).Weight = xlHairline
        Next r
        .[G12:J200,L12:AL200].ClearContents
        .[A12].Resize(K + 20, 50).Locked = False
        .[A12].Resize(K, 7).Locked = True
        .[AL12].Resize(K, 2).Locked = True
        .[K12].Resize(K, 1).Locked = True
        .[K12].Resize(K, 1).Locked = True
        For c = 1 To 4
            Mege .Range("A12").Offset(0, c - 1).Resize(K, 1)
        Next c
        Mege .Range("H12").Resize(K, 1)
        ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True, Password:="123"
    End With
    Application.ScreenUpdating = True
End Sub
Nhưng sao cột [H] Sheet(Mau) vẫn bị Locked không nhập được dữ liệu, bạn xem giùm mình với!.
 
Upvote 0
VetMini đã viết:
VBA và Merged cells là lửa và dầu.
Hai cái này vọc cùng 1 lúc thì thế nào cũng có lúc bỏng.
Nhấp chuột vào đây để mở rộng...
Vâng
Em cũng chỉ mong sao đừng vo tình làm thay đổi dữ liệu khi xuất sang sheet mẫu thôi.
"Người được em gửi mẫu để nhập lại cứ bắt phải Merge" những chỗ đó lại
Mong anh khắc phục giúp!.
 
Lần chỉnh sửa cuối:
Upvote 0
befaint đã viết:
"H12:H" & K + 20 thì nhập dữ liệu bình thường, ngoài vùng này không nhập được.
Nhấp chuột vào đây để mở rộng...
Bạn xem file giúp mình với!, mình đã tet nhiều lần mà "H12:H" vẫn không nhập được, không biết là còn thao tác gì mình chưa làm đúng
 

File đính kèm

Upvote 0
Thuyanhanoi đã viết:
Vâng
Em cũng chỉ mong sao đừng vo tình làm thay đổi dữ liệu khi xuất sang sheet mẫu thôi.
"Người được em gửi mẫu để nhập lại cứ bắt phải Merge" những chỗ đó lại
Mong anh khắc phục giúp!.
Nhấp chuột vào đây để mở rộng...

Bạn nói thẳng với người đòi merge này rằng chuyên viên (*) về dữ liệu và lập trình nói "đã merge thì đừng VBA, đã VBA thì đừng merge"
Nếu ngừoi này là sếp bạn thì xin lỗi, bạn gặp người sếp cứng đầu.

(*) tôi làm việc với bảng tính trải rộng từ hồi nó còn là con đẻ của Lotus 123. Thiết nghĩ tôi tự xưng mình là chuyên viên dữ liệu không quá đáng đâu.
 
Upvote 0
VetMini đã viết:
Bạn nói thẳng với người đòi merge này rằng chuyên viên (*) về dữ liệu và lập trình nói "đã merge thì đừng VBA, đã VBA thì đừng merge"
Nếu ngừoi này là sếp bạn thì xin lỗi, bạn gặp người sếp cứng đầu.

(*) tôi làm việc với bảng tính trải rộng từ hồi nó còn là con đẻ của Lotus 123. Thiết nghĩ tôi tự xưng mình là chuyên viên dữ liệu không quá đáng đâu.
Nhấp chuột vào đây để mở rộng...
- Vâng em sẽ lựa lời ạ!.
- Qua bài mình xin cảm ơn bạn befaint đã nhiệt tình giúp mình!. Mình đã tìm được cách khắc phục rồi!.
Sau dòng
Mã: 
  Mege .Range("H12").Resize(K, 1)
thì chèn thêm dòng này
Mã: 
 .Range("H12").Resize(K, 1).Locked = False
 
Upvote 0
Thuyanhanoi đã viết:
Bạn xem file giúp mình với!, mình đã tet nhiều lần mà "H12:H" vẫn không nhập được, không biết là còn thao tác gì mình chưa làm đúng
Nhấp chuột vào đây để mở rộng...

Mã: 
'...
    Next i
    With Sheets("Mau")
        .Unprotect Password:="123"
        .[A12:AN200].UnMerge
        .[A12:AN200].Borders.LineStyle = 0  [COLOR=#0000ff]'Thêm dòng này[/COLOR]
        .[A12:AN200].ClearContents
        .[A12].Resize(K, 40).Value = dArr
        .[A12].Resize(K, 38).Borders.LineStyle = xlContinuous
        For r = 1 To K Step 2
            .[A11].Offset(r, 0).Resize(2, 38).Borders(xlInsideHorizontal).Weight = xlHairline
        Next r
        .[G12:J200,L12:AL200].ClearContents
        For c = 1 To 4
            Mege .Range("A12").Offset(0, c - 1).Resize(K, 1)
        Next c
        Mege .Range("H12").Resize(K, 1)
        .[A12].Resize(K + 20, 50).Locked = False
        .[A12].Resize(K, 7).Locked = True
        .[AL12].Resize(K, 2).Locked = True
        .[K12].Resize(K, 1).Locked = True
        .Protect DrawingObjects:=True, Contents:=True, Scenarios:=True, Password:="123"
        .EnableSelection = xlUnlockedCells
    End With
    Application.ScreenUpdating = True
End Sub
 
Lần chỉnh sửa cuối:
Upvote 0
Bạn phải đăng nhập hoặc đăng ký để trả lời bài viết tại đây.
Web KT

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

SA_DQ
[Xin hỏi] Cách tính số tiền bình quân của tài khoản trong 1 tháng (1 người xem)
Trả lời
10
Đọc
163
VetMini
V
A
  • Question Question
Nhờ anh chị em chú bác giúp em viết code vba thay cho công thức dò tìm và tính
Trả lời
2
Đọc
62
A HOANG 620
A
ongke0711
  • Question Question
Trộn dữ liệu từ Excel sang Word mở rộng (phiên bản ongke0711)
    • Thích
    • Yêu thích
    • Cảm ơn
12 13 14
Trả lời
262
Đọc
28K
toptikibeauty
T
T
tìm ra số tháng mà lượng hàng nhập ban đầu sử dụng hết
    • Cười
Trả lời
3
Đọc
134
minhminh27
minhminh27
nttrung_proneu
Cách giữ công thức khi lọc và tách file
Trả lời
2
Đọc
60
nttrung_proneu
nttrung_proneu
K
  • Question Question
Code vba đọc QR code file hình ảnh trên CCCD
    • Cười
Trả lời
0
Đọc
63
kingbo.camera
K
Nguyễn Duy Tuân
Phiên bản mới Add-in A-Tools v10 (2024) (1 người xem)
    • Thích
2 3
Trả lời
42
Đọc
3K
Nguyễn Duy Tuân
Nguyễn Duy Tuân
H
  • Question Question
Gửi mail hàng loạt với mỗi mail là 1 file PDF đính kèm khác nhau
Trả lời
1
Đọc
56
minhminh27
minhminh27
B
Làm sao đổi đơn vị B, M này sang hàng đơn vị vậy mọi người? (1 người xem)
    • Cười
Trả lời
4
Đọc
67
Bao Nguyen 89
B
C
Tạo hyperlink hàng loạt
Trả lời
9
Đọc
5K
online.tanphat
O
TrungChinhs
  • Question Question
Hỏi cách làm tròn số trong VBA
Trả lời
9
Đọc
7K
SA_DQ
SA_DQ
dongbhhg
Tìm lương cơ sở theo từng tháng (1 người xem)
Trả lời
3
Đọc
91
dongbhhg
dongbhhg
V
Làm mẫu giấy đi đường (công lệnh) bằng Excel
Trả lời
12
Đọc
11K
Gà Công Nghệ
Gà Công Nghệ
N
Thử lập trình XLL add-in bằng C/C++
    • Thích
Trả lời
0
Đọc
91
nguyendang95
N
Tuấn Bụng Bự
tạo QRcode chuyển khoản ngân hàng
Trả lời
5
Đọc
223
Tuấn Bụng Bự
Tuấn Bụng Bự
M
Tự chèn dòng khi cập nhật dữ liệu từ trang tính khác.
Trả lời
1
Đọc
60
BuiQuangThuan
B
Quách Ngọc
Trả về kết quả ngày tháng hay khoảng trống
Trả lời
3
Đọc
70
Quách Ngọc
Quách Ngọc
MaxanB
Cần hỗ trợ công thức Vlookup nhiều sheet theo điều kiên
Trả lời
2
Đọc
90
MaxanB
MaxanB
N
Không chạy được file VBA
Trả lời
3
Đọc
151
nhjngj
N
N
Xin giúp e cách lọc dữ liệu bị trùng
Trả lời
1
Đọc
77
hoangtuaotrang_hp_vn
H
Xem thêm…

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

Đếm ngược thời gian

000
Ngày
00
Giờ
00
phút
00
giây
TALKSHOW KHÁM PHÁ SỨC MẠNH HÀM FILTER TRONG EXCEL 365
Back
Top Bottom