Code VBA thay thế công thức và tự động chèn hình theo mã (1 người xem)

  • Thread starter Thread starter benktx
  • Ngày gửi Ngày gửi
Elx 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)
B

benktx

Thành viên mới
Tham gia
1/10/07
Bài viết
19
Được thích
0
Nhờ các cao thủ giúp em mã hoá bằng VBA thay cho hàm MID, như trong file đính kèm. Em chân thành cảm ơn!!!
 

File đính kèm

À, công thức của bạn thay vì:

=IF(B8<>0,ABS(MID(B8,FIND("[",B8,1)+1,(FIND("]",B8,1)-1)-(FIND("[",B8,1)))),"")

Thì có thể viết:

=IF(B8<>"",LEFT(RIGHT(B8,2)),"")
 
benktx đã viết:
Nhờ các cao thủ giúp em mã hoá bằng VBA thay cho hàm MID, như trong file đính kèm. Em chân thành cảm ơn!!!
Nhấp chuột vào đây để mở rộng...

Code vầy thử xem:
Mã: 
Sub Main()
  Dim lPos1 As Long, lPos2 As Long, lR As Long
  Dim aSrc
  Dim tmp1 As String, tmp2 As String
  aSrc = Sheet2.Range("B8:B1000")
  ReDim aDes(1 To UBound(aSrc, 1), 1 To 1)
  For lR = 1 To UBound(aSrc, 1)
    tmp1 = CStr(aSrc(lR, 1))
    If Len(tmp1) Then
      lPos1 = InStr(1, tmp1, "[")
      If lPos1 Then
        lPos2 = InStr(1, tmp1, "]")
        If lPos2 Then
          If lPos2 > lPos1 Then
            tmp2 = Mid(tmp1, lPos1 + 1, lPos2 - lPos1 - 1)
            aDes(lR, 1) = tmp2
          End If
        End If
      End If
    End If
  Next
  Sheet2.Range("C8").Resize(UBound(aDes, 1)).Value = aDes
End Sub
Cảnh bảo: Tôi thấy trong file bạn code dùng sự kiện Worksheet_Change tại cột C. Tuy nhiên, khi code trên chạy xong, giá trị cột C có thể thay đổi nhưng sẽ không kích hoạt sự kiện Change đã có đâu nha!
--------------------------
Hoàng Trọng Nghĩa đã viết:
À, công thức của bạn thay vì:

=IF(B8<>0,ABS(MID(B8,FIND("[",B8,1)+1,(FIND("]",B8,1)-1)-(FIND("[",B8,1)))),"")

Thì có thể viết:

=IF(B8<>"",LEFT(RIGHT(B8,2)),"")
Nhấp chuột vào đây để mở rộng...
Nếu có chuỗi .....[10] thì sao? Ai mà chắc nhỉ? Ẹc... Ẹc...
 
Lần chỉnh sửa cuối:
Hoàng Trọng Nghĩa đã viết:
Vì file chỉ đưa ra 9 mẫu, làm vậy cho lành! Còn không cũng có thể làm cái này nhỉ?

=IF(B8<>"",SUBSTITUTE(RIGHT(B8,LEN(B8)-FIND("[",B8)),"]",""),"")
Nhấp chuột vào đây để mở rộng...

Vấn đề cuối cùng là người ta không muốn công thức chàng ơi!
Người ta muốn nhấn nút, nó tính ra kết quả luôn
Ẹc... Ẹc...
 
ndu96081631 đã viết:
Code vầy thử xem:
Mã: 
Sub Main()
  Dim lPos1 As Long, lPos2 As Long, lR As Long
  Dim aSrc
  Dim tmp1 As String, tmp2 As String
  aSrc = Sheet2.Range("B8:B1000")
  ReDim aDes(1 To UBound(aSrc, 1), 1 To 1)
  For lR = 1 To UBound(aSrc, 1)
    tmp1 = CStr(aSrc(lR, 1))
    If Len(tmp1) Then
      lPos1 = InStr(1, tmp1, "[")
      If lPos1 Then
        lPos2 = InStr(1, tmp1, "]")
        If lPos2 Then
          If lPos2 > lPos1 Then
            tmp2 = Mid(tmp1, lPos1 + 1, lPos2 - lPos1 - 1)
            aDes(lR, 1) = tmp2
          End If
        End If
      End If
    End If
  Next
  Sheet2.Range("C8").Resize(UBound(aDes, 1)).Value = aDes
End Sub

Cám ơn thầy, em đã tính được kết quả nhưng làm sao để cột E tự động cập nhật hình dáng thanh thép. Hiện tại thì em click đúp vào thì nó mới cập nhật hình dáng thanh. Điều em cần là tự động cập nhật hình dáng thanh bằng 1 nút bấm. Thầy giúp em với.
Nhấp chuột vào đây để mở rộng...
 

File đính kèm

benktx đã viết:
Cám ơn thầy, em đã tính được kết quả nhưng làm sao để cột E tự động cập nhật hình dáng thanh thép. Hiện tại thì em click đúp vào thì nó mới cập nhật hình dáng thanh. Điều em cần là tự động cập nhật hình dáng thanh bằng 1 nút bấm. Thầy giúp em với.
Nhấp chuột vào đây để mở rộng...

Xem trong file là biết ngay thế nào cũng có yêu cầu này! Sao bạn không nêu ra ngay từ đầu cho người ta đở mất công?
Bây giờ sửa code lại duyệt theo từng cell bình thường:
Mã: 
Sub Main()
  Dim lPos1 As Long, lPos2 As Long
  Dim rng As Range, cel As Range
  Dim tmp1 As String, tmp2 As String
  Application.ScreenUpdating = False
  Set rng = Sheet2.Range("B8", Sheet2.Range("B60000").End(xlUp))
  For Each cel In rng
    tmp1 = CStr(cel.Value)
    If Len(tmp1) Then
      lPos1 = InStr(1, tmp1, "[")
      If lPos1 Then
        lPos2 = InStr(1, tmp1, "]")
        If lPos2 Then
          If lPos2 > lPos1 Then
            tmp2 = Mid(tmp1, lPos1 + 1, lPos2 - lPos1 - 1)
            cel.Offset(, 1).Value = tmp2
          End If
        End If
      End If
    End If
  Next
  Application.ScreenUpdating = True
End Sub
Lý ra nếu có thời gian tôi sẽ làm bài này theo hướng khác hay hơn...
 
Lần chỉnh sửa cuối:
ndu96081631 đã viết:
Xem trong file là biết ngay thế nào cũng có yêu cầu này! Sao bạn không nêu ra ngay từ đầu cho người ta đở mất công?
Bây giờ sửa code lại duyệt theo từng cell bình thường:
Mã: 
Sub Main()
  Dim lPos1 As Long, lPos2 As Long
  Dim rng As Range, cel As Range
  Dim tmp1 As String, tmp2 As String
  Application.ScreenUpdating = False
  Set rng = Sheet2.Range("B8", Sheet2.Range("B60000").End(xlUp))
  For Each cel In rng
    tmp1 = CStr(cel.Value)
    If Len(tmp1) Then
      lPos1 = InStr(1, tmp1, "[")
      If lPos1 Then
        lPos2 = InStr(1, tmp1, "]")
        If lPos2 Then
          If lPos2 > lPos1 Then
            tmp2 = Mid(tmp1, lPos1 + 1, lPos2 - lPos1 - 1)
            cel.Offset(, 1).Value = tmp2
          End If
        End If
      End If
    End If
  Next
  Application.ScreenUpdating = True
End Sub
Lý ra nếu có thời gian tôi sẽ làm bài này theo hướng khác hay hơn...
Nhấp chuột vào đây để mở rộng...
Em đã làm được rồi, cảm ơn thầy đã giúp đỡ. }}}}}}}}}}}}}}}}}}}}}}}}}
 

File đính kèm

  • Untitled.jpg
    Untitled.jpg
    21.4 KB · Đọc: 106
Có một vấn đề phát sinh là em muốn có 1 VBA xóa hình dáng các thanh ở cột E trước khi cho chạy cập nhật hình dáng mới. Vì em test thử nếu không xóa thì nhiều khi file chạy bị chồng hình lên nhau. Và khi file có nhiều dòng thì nó chạy không đúng nữa. Nhờ thầy chỉ giúp.
 

File đính kèm

Lần chỉnh sửa cuối:
benktx đã viết:
Em up lại file, file trên bị lỗi.
Nhấp chuột vào đây để mở rộng...

Với số lượng 1000 dòng (tương ứng 1000 hình) và tương lai có thể nhiều hơn thế thì e rằng bạn nên xem lại...
- Thứ nhất: Số lượng hình ảnh quá nhiều sẽ khiến cho file nặng và chậm chạp
- Thứ hai: Chèn hình với số lượng lớn, code chạy không nỗi và có thể làm "treo" luôn Excel
Phải tính lại cách khác thôi
 
ndu96081631 đã viết:
Với số lượng 1000 dòng (tương ứng 1000 hình) và tương lai có thể nhiều hơn thế thì e rằng bạn nên xem lại...
- Thứ nhất: Số lượng hình ảnh quá nhiều sẽ khiến cho file nặng và chậm chạp
- Thứ hai: Chèn hình với số lượng lớn, code chạy không nỗi và có thể làm "treo" luôn Excel
Phải tính lại cách khác thôi
Nhấp chuột vào đây để mở rộng...
Em tìm trên GPE có file thống kê cũng gần giống như file em đang làm, nhưng họ hình dáng thanh thép họ xuất sang không phải là hình mà là đối tượng vẽ trong excel luôn. Tiếc là file có password nên em không nghiên cứu được gì. Thầy xem giúp em với.
 

File đính kèm

benktx đã viết:
Em tìm trên GPE có file thống kê cũng gần giống như file em đang làm, nhưng họ hình dáng thanh thép họ xuất sang không phải là hình mà là đối tượng vẽ trong excel luôn. Tiếc là file có password nên em không nghiên cứu được gì. Thầy xem giúp em với.
Nhấp chuột vào đây để mở rộng...

Khóa password rồi thì thôi, khỏi cần tham khảo... bởi vì cái của người ta chưa chắc gì đã ngon lành đâu
(tôi phát hiện nó vẽ chẳng chính xác tí nào)
 
benktx đã viết:
Em đang chờ VBA mới tốt hơn của thầy.
Nhấp chuột vào đây để mở rộng...

Không dám nói là tốt hơn nhưng cứ.. thử xem
Code vầy:
Mã: 
Public Const strPath As String = "D:\TempPics"
Private Sub Auto_Open()
  Dim cel As Range, IPic As IPictureDisp
  Dim strFile As String
  With CreateObject("Scripting.FileSystemObject")
    If Not .FolderExists(strPath) Then .CreateFolder strPath
    For Each cel In [COLOR=#0000cd]Worksheets("Data").Range("B3:B11")[/COLOR]
      Set IPic = [COLOR=#ff0000]PictureFromObject(cel)[/COLOR]
      strFile = strPath & "\" & cel.Offset(, -1).Value & ".bmp"
      SavePicture IPic, strFile
    Next
  End With
End Sub
Private Sub Auto_Close()
  CreateObject("Scripting.FileSystemObject").DeleteFolder strPath
End Sub
Sub Main()
  Dim lPos1 As Long, lPos2 As Long
  Dim rng As Range, cel As Range, fso As Object
  Dim tmp1 As String, tmp2 As String, strFile As String
  On Error Resume Next
  Application.ScreenUpdating = False
  Set fso = CreateObject("Scripting.FileSystemObject")
  Set rng = Sheet2.Range("B8", Sheet2.Range("B60000").End(xlUp))
  For Each cel In rng
    tmp1 = CStr(cel.Value)
    If Len(tmp1) Then
      lPos1 = InStr(1, tmp1, "[")
      If lPos1 Then
        lPos2 = InStr(1, tmp1, "]")
        If lPos2 Then
          If lPos2 > lPos1 Then
            tmp2 = Mid(tmp1, lPos1 + 1, lPos2 - lPos1 - 1)
            strFile = strPath & "\" & tmp2 & ".bmp"
            cel.Offset(, 1).Value = tmp2
            With cel.Offset(, 3)
              .ClearComments
              If fso.FileExists(strFile) Then
                .AddComment: .Comment.Visible = True
                With .Comment.Shape
                  .Shadow.Visible = msoFalse
                  .Line.ForeColor.RGB = vbWhite
                  .AutoShapeType = msoShapeRectangle
                  .Left = cel.Offset(, 3).Left: .Top = cel.Top
                  .Width = cel.Offset(, 3).Width: .Height = cel.Height
                  .ScaleWidth 0.9, msoFalse, msoScaleFromMiddle
                  .ScaleHeight 0.9, msoFalse, msoScaleFromMiddle
                  .Fill.UserPicture strFile
                End With
              End If
            End With
          End If
        End If
      End If
    End If
  Next
  Application.ScreenUpdating = True
  MsgBox "Cap nhat xong!"
End Sub
Trong file có dùng đến hàm PictureFromObject (tham khảo bên trong file nhé)
Chỗ màu xanh là vùng Data của bạn, có thể sửa lại cho phù hợp (nếu có thay đổi)
------------------
Chạy thử xem tốc độ thế nào
 

File đính kèm

Lần chỉnh sửa cuối:
ndu96081631 đã viết:
Không dám nói là tốt hơn nhưng cứ.. thử xem
Code vầy:
Mã: 
Public Const strPath As String = "D:\TempPics"
Private Sub Auto_Open()
  Dim cel As Range, IPic As IPictureDisp
  Dim strFile As String
  With CreateObject("Scripting.FileSystemObject")
    If Not .FolderExists(strPath) Then .CreateFolder strPath
    For Each cel In [COLOR=#0000cd]Worksheets("Data").Range("B3:B11")[/COLOR]
      Set IPic = [COLOR=#ff0000]PictureFromObject(cel)[/COLOR]
      strFile = strPath & "\" & cel.Offset(, -1).Value & ".bmp"
      SavePicture IPic, strFile
    Next
  End With
End Sub
Private Sub Auto_Close()
  CreateObject("Scripting.FileSystemObject").DeleteFolder strPath
End Sub
Sub Main()
  Dim lPos1 As Long, lPos2 As Long
  Dim rng As Range, cel As Range, fso As Object
  Dim tmp1 As String, tmp2 As String, strFile As String
  On Error Resume Next
  Application.ScreenUpdating = False
  Set fso = CreateObject("Scripting.FileSystemObject")
  Set rng = Sheet2.Range("B8", Sheet2.Range("B60000").End(xlUp))
  For Each cel In rng
    tmp1 = CStr(cel.Value)
    If Len(tmp1) Then
      lPos1 = InStr(1, tmp1, "[")
      If lPos1 Then
        lPos2 = InStr(1, tmp1, "]")
        If lPos2 Then
          If lPos2 > lPos1 Then
            tmp2 = Mid(tmp1, lPos1 + 1, lPos2 - lPos1 - 1)
            strFile = strPath & "\" & tmp2 & ".bmp"
            cel.Offset(, 1).Value = tmp2
            With cel.Offset(, 3)
              .ClearComments
              If fso.FileExists(strFile) Then
                .AddComment: .Comment.Visible = True
                With .Comment.Shape
                  .Shadow.Visible = msoFalse
                  .Line.ForeColor.RGB = vbWhite
                  .AutoShapeType = msoShapeRectangle
                  .Left = cel.Offset(, 3).Left: .Top = cel.Top
                  .Width = cel.Offset(, 3).Width: .Height = cel.Height
                  .ScaleWidth 0.9, msoFalse, msoScaleFromMiddle
                  .ScaleHeight 0.9, msoFalse, msoScaleFromMiddle
                  .Fill.UserPicture strFile
                End With
              End If
            End With
          End If
        End If
      End If
    End If
  Next
  Application.ScreenUpdating = True
  MsgBox "Cap nhat xong!"
End Sub
Trong file có dùng đến hàm PictureFromObject (tham khảo bên trong file nhé)
Chỗ màu xanh là vùng Data của bạn, có thể sửa lại cho phù hợp (nếu có thay đổi)
------------------
Chạy thử xem tốc độ thế nào
Nhấp chuột vào đây để mở rộng...
"Quá nhanh và quá nguy hiểm" tốc độ 3s/1000 row, thầy quá siêu.
Tuy nhiên khi in thì hình dáng thanh không thấy và hide cột B&C thì hình dạng không di chuyển theo cột E , thầy xem giúp em chỗ này, và em cần thêm cái VBA xóa hình dáng thanh cũ trước khi cập nhật cái mới. Cám ơn thầy rất nhiều.
 
Lần chỉnh sửa cuối:
benktx đã viết:
Tuy nhiên khi in thì hình dáng thanh không thấy, thầy xem giúp em chỗ này
Nhấp chuột vào đây để mở rộng...

Tại vì hình ấy chèn trong comment. Muốn in được comment phải chỉnh trong Page Setup
Xem tại đây:
http://www.giaiphapexcel.com/forum/...nh-sách-và-insert-copy-đc&p=334774#post334774
benktx đã viết:
và em cần thêm cái VBA xóa hình dáng thanh cũ trước khi cập nhật cái mới. Cám ơn thầy rất nhiều.
Nhấp chuột vào đây để mở rộng...
Cứ chạy code đi, tự cái cũ sẽ bị xóa thôi
 
Em hiểu ý thầy, nhưng vì nếu em copy 1 sheet mới từ sheet đã tính toán rồi nhưng dữ liệu có số dòng ít hơn thì nó sẽ thừa các hình dáng của sheet cũ.
 
benktx đã viết:
Em hiểu ý thầy, nhưng vì nếu em copy 1 sheet mới từ sheet đã tính toán rồi nhưng dữ liệu có số dòng ít hơn thì nó sẽ thừa các hình dáng của sheet cũ.
Nhấp chuột vào đây để mở rộng...

Bạn chạy Sub này là được:
Mã: 
Sub DelComm()
  Sheet2.Range("E8:E60000").ClearComments
End Sub
 
Em đã làm được.
Cảm ơn sự giúp đỡ của thầy, cảm ơn GPE rất nhiều!!!!
 
Em đang bí VBA hàm MID với 2 dạng dữ liệu nhờ thầy gỡ giúp em. Thầy xem file để rõ hơn nhé.
 

File đính kèm

nếu chỉ có 2 dạng đó thôi thì hàm ếch vẫn xài
Mã: 
=MID(A3,FIND("C",A3)+1,IFERROR( FIND("a150",A3),FIND("L",A3))-FIND("C",A3)-1)
 
doveandrose đã viết:
nếu chỉ có 2 dạng đó thôi thì hàm ếch vẫn xài
Mã: 
=MID(A3,FIND("C",A3)+1,IFERROR( FIND("a150",A3),FIND("L",A3))-FIND("C",A3)-1)
Nhấp chuột vào đây để mở rộng...
Cảm ơn bạn, hàm này nếu giá trị không phải "a150" thì nó không còn đúng nữa, nên sửa lại "FIND("a",A3)" thì sẽ đúng. Với lại mình đang muốn có code VBA để đồng bộ với file mình đang xây dựng.
 
Bạn phải đăng nhập hoặc đăng ký để trả lời bài viết tại đây.

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

ongke0711
  • Question Question
Tải hóa đơn điện tử (https://hoadondientu.gdt.gov.vn/) Excel Vba (11 người xem)
    • Thích
    • Yêu thích
    • Cảm ơn
4 5 6
Trả lời
554
Đọc
72K
sát thủ uyên ương
S
C
Fix lỗi Application.InputBox Type:=8 (4 người xem)
    • Cười
Trả lời
6
Đọc
96
SA_DQ
SA_DQ
Emyeuexcel
Tham chiếu về 1 ô-lấy ra và lọc dữ liệu (3 người xem)
Trả lời
5
Đọc
87
Emyeuexcel
Emyeuexcel
L
Hỏi lỗi excel bị tràn trang khi in (2 người xem)
Trả lời
3
Đọc
63
Hoàng Tuấn 868
H
E
  • Question Question
VBA tự động thay đổi tham chiếu vùng (range và cell) khi insert dòng cột trong sheet tính toán (2 người xem)
    • Cười
Trả lời
5
Đọc
119
eagle12
E
D
Tổng hợp dữ liệu từ các sheet sang sheet tổng (1 người xem)
Trả lời
3
Đọc
146
dohungmo
D
T
font chu trong excel (1 người xem)
Trả lời
2
Đọc
69
Hoàng Tuấn 868
H
khuong182018
  • Question Question
Nhờ anh chị sửa lỗi setfocus ở textbox (2 người xem)
Trả lời
9
Đọc
163
khuong182018
khuong182018
N
File chia băng tự động từ cuộn mẹ theo khổ băng và khối lượng băng cho trước
Trả lời
0
Đọc
42
nguyenanhtruong2409
N
SA_DQ
Copilot bình luận về một ván cờ vua (1 người xem)
Trả lời
0
Đọc
73
SA_DQ
SA_DQ
T
Xin giúp đỡ lọc dữ liệu (2 người xem)
    • Cười
Trả lời
4
Đọc
114
pycckuu410
pycckuu410
Nguyễn Duy Tuân
[New] BSAC v3.0 bộ công cụ lập trình phần mềm chuyên nghiệp trong VBA (1 người xem)
    • Thích
Trả lời
13
Đọc
4K
Nguyễn Duy Tuân
Nguyễn Duy Tuân
H
  • Question Question
Code Sổ Chi Tiết Tài Khoản (1 người xem)
Trả lời
8
Đọc
326
hieuvietmy2020
H
befaint
Chia sẻ tâm tư, xả nỗi lòng (4 người xem)
    • Thích
6 7 8
Trả lời
778
Đọc
75K
SA_DQ
SA_DQ
H
Chia sẻ file in Phiếu điều tra PCGD (1 người xem)
    • Thích
    • Yêu thích
    • Cảm ơn
Trả lời
12
Đọc
442
HUONGHCKT
H
V
Hỏi công thức để làm khối lượng trong xây dựng. Xin cảm ơn
Trả lời
11
Đọc
522
phanphu_91
P
Linhnv0001
Hỏi - Cách kiểm tra laptop là hàng lắp ráp hay không (1 người xem)
Trả lời
3
Đọc
275
Lê Duy Thương
Lê Duy Thương
K
Nhờ anh chị làm công thức lọc dữ kiện ngày từ bảng 1 sang rút gọn ngày ở bảng 2.
Trả lời
2
Đọc
186
Lê Duy Thương
Lê Duy Thương
L
[Mẹo] Không chọn Add-in vẫn có thể sử dụng được chức năng của Add-in, giảm tốc độ loading của Excel.
    • Thích
Trả lời
2
Đọc
497
HeSanbi
HeSanbi
GPE-Trợ Lý
[GPE18] KỸ THUẬT BIỂU ĐỒ NÂNG CAO CHO DASHBOARD: TRỰC QUAN HÓA TIẾN ĐỘ THỰC HIỆN KẾ HOẠCH
    • Thích
Trả lời
2
Đọc
9K
ptm0412
ptm0412
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

Thời gian đếm ngược.

000
Ngày
00
Giờ
00
phút
00
giây
Thân mời tham dự sự kiện sinh nhật GPE 2025
Back
Top Bottom