[Share] Tools nhỏ nhỏ gán lên thanh Ribbon

[hungtin1997]

Xin chào mọi người,

Mò VBA được tầm 1 tháng code được 1 số thứ nhỏ nhỏ hay dùng, hơi cùi nhưng hy vọng giúp 1 số bạn cần dùng giống em. Em thì dùng trong công ty nên ngại gửi file mail file xslm lắm, nên code để gán lên Ribbon dùng cho file xlsx thôi(câu trên). Nhiều bác hay la: "Tại sao không gõ trực tiếp vào code mấy cái biến mà cứ phải Inputbox các kiểu,..." thì câu trên là lý do ạ.



1. Thêm dòng/cột:
Chỉ thêm cột/dòng ở vùng quét(chèn right/down).

Sub Themcot()
a = MsgBox("Them cot hay dong?" & Chr(10) & "Yes = Cot" & Chr(10) & "No = Dong", vbYesNoCancel, "Thông báo")
If a = vbCancel Then GoTo thoat
Set o = Application.InputBox("Chon Vung DL", "Thông Báo", Type:=8)
col = InputBox("So cot/dong can them", "Thông báo")
c = o.Columns.Count
d = o.Rows.Count
Application.ScreenUpdating = False
If a = vbYes Then
For i = c To 2 Step -1
     Range(o(1, i), o(d, i + col - 1)).Select
     Selection.Insert Shift:=xlToRight
Next
Else
For i = d * col To 2 Step -1
     Range(o(i, 1), o(i + col - 1, c)).Select
     Selection.Insert Shift:=xlDown
Next
Application.ScreenUpdating = True
End If
thoat:
Exit Sub
End Sub

2. Tạo số ngẫu nhiên từ từ Max/Min của 1 vùng với Decimal=6

Sub rand_maxmin()
Dim arr As Variant
Dim r As Variant
Dim o As Range
On Error Resume Next
Set App = Application.WorksheetFunction
Set r = Application.InputBox("Chon Vung Max_Min", "Thông Báo!", Type:=8)
Set o = Application.InputBox("Chon Vung Dan DL", "Thông Báo!", Type:=8)
ReDim arr(1 To o.Rows.Count, 1 To o.Columns.Count)
For i = 1 To o.Rows.Count
For x = 1 To o.Columns.Count
arr(i, x) = App.RandBetween(App.Min(r) * 10 ^ 6, App.Max(r) * 10 ^ 6) / 10 ^ 6
Next
Next
o = arr
End Sub

3. Tạo Cells lặp lại theo cột với hai nguyên tắc:
a. Tao 1 cột mới giống như copy cột nguồn và dán nối tiếp xuống dưới n lần
b. Tạo 1 cột với các phần từ của cột nguồn lặp lại n lần cho đến khi hết ô trong cột nguồn.

Sub tao_du_tieu()
On Error GoTo err
Dim i, Solan, SoDL, Tong, Idx
Dim dl As Variant
Dim App
Set App = Application.WorksheetFunction
Set dl = Application.InputBox("Vung_DL", "Thông Báo!", Type:=8)
Application.ScreenUpdating = False
Solan = InputBox("Nhap so lan: ", "Thông báo")
SoDL = dl.Rows.Count
Tong = Solan * SoDL
Set Ws = Sheets(ActiveSheet.Name)
Sheets.Add(after:=ActiveSheet).Name = "Item" & Sheets.Count
For i = 1 To Tong
    Idx = ((i - 1) Mod SoDL) + 1
    Cells(i, 1) = dl.Cells(Idx, 1)
    Idx = Int((i - 1) / Solan) + 1
    Cells(i, 2) = dl.Cells(Idx, 1)
Next i
Exit Sub
Application.ScreenUpdating = True
err:
Exit Sub
End Sub

4.In Excel qua PDF:
- Nhập STT sheets cần in và chọn 1 lúc nhiều file để in
- Điều kiện là các sheet trong file cần in phải set sẵn(code in cả sheet)

Sub inpdf()
Dim Chonfile As Variant
Dim i As Integer
Dim openfile As Workbook
Dim sh As Integer
Dim wb As Workbook
Dim tmr As Double
Set wb = ActiveWorkbook
Set Ws = ThisWorkbook.ActiveSheet
Application.ScreenUpdating = False
Application.DisplayAlerts = False
On Error GoTo ErrorHandler
sh = InputBox("STT sheet can In", "Thông Báo!")
Chonfile = Application.GetOpenFilename(Title:="Chon file", filefilter:="Excel file (*.xls*), *.xls*", MultiSelect:=True)
tmr = Timer()
Sheets.Add after:=ActiveSheet
For i = 1 To UBound(Chonfile)
        Set openfile = Workbooks.Open(Chonfile(i))
       wb.ActiveSheet.Range("A" & i).Value = openfile.Name
        openfile.Sheets(sh).Select
        ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, FileName:=Left(Right(openfile.Name, Len(openfile.Name) - 6), 8), Quality:=xlQualityStandard, _
  IncludeDocProperties:=False, IgnorePrintAreas:=False, OpenAfterPublish:=True
        openfile.Close False
Next
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.Assistant.DoAlert "THÔNG BÁO", ChrW(272) & "ã in " & UBound(Chonfile) & " file trong " & Left(Timer() - tmr, 4) & " giây" & vbCrLf & "Cùng " & ChrW(273) & ChrW(432) & ChrW(7901) & _
          "ng d" & ChrW(7851) & "n v" & ChrW(7899) & "i file Excel", 0, 4, 0, 0, 0
Exit Sub
ErrorHandler:
Application.Assistant.DoAlert "THÔNG BÁO", "Ch" & ChrW(432) & "a " & ChrW(273) & ChrW(7911) _
          & " " & ChrW(273) & "i" & ChrW(7873) & "u ki" & ChrW(7879) & "n " & ChrW( _
          273) & ChrW(7875) & " In", 0, 4, 0, 0, 0
Exit Sub
End Sub

5. Copy (Thật ra là link tưng ô) nhiều file thành 1 sheet (file nguồn đóng)
- Giống như mở file nguồn lên = công thức đến file nguồn rồi đóng file nguồn, sau đó copy và dán giá trị.
- Phải khai báo tên sheet và vùng cần lấy dữ liệu (cái này là do công ty em dùng cùng form cho nhiều lot hàng nên cùng format)

Sub copfile()
Dim Chonfile As Variant
Dim i As Integer
Dim sh As String
Dim r As String
Dim dong As Integer
Dim cot As Integer
Set wb = ActiveWorkbook
Application.DisplayAlerts = False
Dim tmr As Double
On Error GoTo ErrorHandler
sh = InputBox("Tên sheet can copy", "Thông Báo!") ' "datadcs"
r = InputBox("Vung can copy" & Chr(10) & "Vd: A1:AJ19", "Thông báo!") '"a1:aj19"
Application.ScreenUpdating = False
tmr = Timer()
dong = Range(r).Rows.Count
cot = Range(r).Columns.Count
Chonfile = Application.GetOpenFilename(Title:="Chon file", filefilter:="Excel file (*.xls*), *.xls*", MultiSelect:=True)
Sheets.Add after:=ActiveSheet
For i = 1 To UBound(Chonfile)
     Range(Cells(i, 1), Cells(i, 2)) = Chonfile(i)
     Range(Cells(1, 2), Cells(i, 2)).Replace what:="*\", Replacement:=""
     Cells(i, 3).FormulaR1C1 = _
        "=LEFT(RC[-2]:R[6]C[-2],LEN(RC[-2]:R[6]C[-2])-LEN(RC[-1]:R[6]C[-1]))&""[""&RC[-1]:R[6]C[-1]&""]"""
     Cells(i, 3) = Cells(i, 3).Value & sh & "'!" & r
     Range(Cells(i * dong - (dong - 1), 4), Cells(i * dong, cot + 3)).FormulaArray = "='" & Cells(i, 3)
     Range(Cells(i * dong - (dong - 1), 4), Cells(i * dong, cot + 3)) = Range(Cells(i * dong - (dong - 1), 4), Cells(i * dong, cot + 3)).Value
Next
Range("A:A,C:C").Delete
Range("A:A").EntireColumn.AutoFit
ActiveSheet.Name = UBound(Chonfile) & "lot_in_" & Left(Timer() - tmr, 3) & "s"
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Exit Sub
ErrorHandler:
Application.Assistant.DoAlert "THÔNG BÁO", "Ch" & ChrW(432) & "a " & ChrW(273) & ChrW(7911) _
          & " " & ChrW(273) & "i" & ChrW(7873) & "u ki" & ChrW(7879) & "n " & ChrW( _
          273) & ChrW(7875) & " Copy", 0, 4, 0, 0, 0
Exit Sub
End Sub

6. Tự Resize tất cả các ảnh có trong sheet vào ô hoặc merge với offset từ viền vào (Nguồn GPE, @batman1 )

Sub ResizePictureCells()
Dim DelTa As Double, Pic As Shape
    On Error Resume Next
    DelTa = InputBox("Offset", "Thông Báo")
   answer = MsgBox("Ban muon tao khung anh ?", vbQuestion + vbYesNo + vbDefaultButton2, "Thông báo")
    For Each Pic In ActiveSheet.Shapes
        With Pic.TopLeftCell
            Pic.LockAspectRatio = 0
            Pic.Top = .MergeArea.Top + DelTa
            Pic.Left = .MergeArea.Left + DelTa
            Pic.Width = .MergeArea.Width - 2 * DelTa
            Pic.Height = .MergeArea.Height - 2 * DelTa
            If answer = 6 Then
            Pic.Line.Visible = msoTrue
            Pic.Line.Weight = 0.75
            Else
            Pic.Line.Visible = msoFalse
            End If
        End With
    Next Pic
End Sub

Các vị tiền bối nếu thấy code em cùi hoặc chậm chỗ nào thì em xin nhận góp ý ạ.
Em chưa rành về code nhiều lắm nên hay record , áp dụng hàm, thậm chí Ctrl+H
Xin cảm ơn mọi người đã đọc bài viết.

 

[Nhattanktnn]

Nguồn GPE, xin lỗi vì không nhớ chính xác tên tác giả

Cái bác ở Ba Lan ý

 

[hungtin1997]

Cái bác ở Ba Lan ý

Bác biết chính xác tên không?

 

[Nhattanktnn]

Bác biết chính xác tên không?

Người dơi 1

Bài đã được tự động gộp: 7/11/20

Gửi bạn link luôn nè
https://giaiphapexcel.com/diendan/threads/chỉnh-ảnh-vừa-ô-bằng-vba.152621/#post-998804