April 28, 2009

Membuat KOP secara Makro menggunakan Excel

Oke, oke...
Selama ada usaha disitu ada jalan bung!
Berhasil atau tidak tergantung usahanya. Kalau modal besar, besar pula peluangnya.
Jadi ngelantur...Sory, beberapa minggu ini, sinyal UMTS di tempat saya hilang, lenyap ziiip! Jadi terkendala. Sms-an hal begini ogah ah..mahal!
Buat mas DS, Kop sekolah ya?
Pertama-tama silakan mas download file berikut ini: MacroKop.zip

Atau jika telah mengerti VBA, silakan copy-paste kode berikut ini pada VBA Excel.


Sub Kop()
'By Yopibest�2009
Dim NamaFile As String
NamaFile = ""
Dim KolomAkhir As String
Dim KolomAwal As String
Dim Lebar As Single
On Error GoTo Salah
KolomAwal = Awal
KolomAkhir = Akhir
Dim cekKolomAwal As String
Dim cekKolomAkhir As String
cekKolomAwal = Awal
cekKolomAkhir = Akhir
Dim i As Integer
Dim Col As Integer
Dim intKolom As Integer
Dim JlhKolom As Integer
JlhKolom = (AscW(cekKolomAkhir) - AscW(cekKolomAwal))
For Col = 0 To JlhKolom
For i = 1 To 4
Range(cekKolomAwal & i).Select
If IsEmpty(ActiveCell.Value) = False Then
Call Salah
Exit Sub
End If
Next i
intKolom = AscW(cekKolomAwal) + 1
cekKolomAwal = Chr(intKolom)
Next Col
Range(KolomAwal & "1", KolomAkhir & "1").Select
Selection.Merge
ActiveCell.HorizontalAlignment = xlCenter
ActiveCell.FormulaR1C1 = "BARIS PERTAMA"
ActiveCell.Font.Name = "Bookman Old Style"
ActiveCell.Font.Size = 11
Range(KolomAwal & "2", KolomAkhir & "2").Select
Selection.Merge
ActiveCell.HorizontalAlignment = xlCenter
ActiveCell.FormulaR1C1 = "BARIS KEDUA"
ActiveCell.Font.Name = "Bookman Old Style"
ActiveCell.Font.Size = 11
Range(KolomAwal & "3", KolomAkhir & "3").Select
Selection.Merge
ActiveCell.HorizontalAlignment = xlCenter
ActiveCell.FormulaR1C1 = "BARIS KETIGA"
ActiveCell.Font.Name = "Bookman Old Style"
ActiveCell.Font.Size = 12
Range(KolomAwal & "4", KolomAkhir & "4").Select
Selection.Merge
ActiveCell.HorizontalAlignment = xlCenter
ActiveCell.FormulaR1C1 = "BARIS KEEMPAT"
ActiveCell.Font.Name = "Bookman Old Style"
ActiveCell.Font.Size = 10
Selection.Font.Underline = xlUnderlineStyleDouble
Range(KolomAwal & "1", KolomAkhir & "1").Select
If NamaFile = "" Then
If NamaFile = "" Then
MsgBox "File logo belum ditentukan", vbOKOnly, "Logo"
Else
MsgBox "File logo tidak temukan", vbOKOnly, "Logo"
End If
Call Margin
Windows("MacroKop.xls").Close
Exit Sub
End If
If UCase$(KolomAwal) = "A" Then
Lebar = Selection.Width
ActiveSheet.Pictures.Insert(NamaFile).Select
Selection.Left = (Lebar - (351 + ((Lebar - 351) / 2)) - 48)
Selection.ShapeRange.PictureFormat.ColorType = msoPictureBlackAndWhite
Else
Range("A1", KolomAwal & "1").Select
Lebar = Selection.Width
Range(KolomAwal & "1", KolomAkhir & "1").Select
Lebar = Lebar - Selection.Width
ActiveSheet.Pictures.Insert(NamaFile).Select
Selection.Left = Lebar
Selection.ShapeRange.PictureFormat.ColorType = msoPictureBlackAndWhite
End If
Selection.Top = 0
Range(KolomAwal & "1", KolomAkhir & "4").Select
Call Margin
Windows("MacroKop.xls").Close
Exit Sub
Salah:
MsgBox "Anda tidak melakukan seleksi terhadap seluruh Judul Kolom pada Tabel" & vbCrLf & vbCrLf & _
"Lakukan seleksi (BLOK) seluruh Judul Kolom pada Tabel terlebih dahulu!", vbInformation, "Anda Keliru !!!!!!"
Windows("MacroKop.xls").Close
End Sub

Sub Margin()
With ActiveSheet.PageSetup
.LeftMargin = Application.InchesToPoints(0.393700787401575)
.RightMargin = Application.InchesToPoints(0.393700787401575)
.TopMargin = Application.InchesToPoints(0.590551181102362)
.BottomMargin = Application.InchesToPoints(0.590551181102362)
.HeaderMargin = Application.InchesToPoints(0.511811023622047)
.FooterMargin = Application.InchesToPoints(0.511811023622047)
.CenterHorizontally = True
.Order = xlDownThenOver
End With
End Sub

Function Awal()
'By Yopibest�2009
Dim str As String, strArr() As String
Dim Int1 As Integer, Int2 As Integer
str = Replace(Selection.Address, "$", "")
strArr = Split(str, ":")
Int1 = AscW(UCase(Mid$(strArr(0), 1, 1)))
Int2 = AscW(UCase(Mid$(strArr(0), 2, 1)))
If Int1 <= 90 And Int1 >= 65 Then
If Int2 <= 90 And Int2 >= 65 Then
Awal = Chr(Int1) & Chr(Int2)
Else
Awal = Chr(Int1)
End If
End If
End Function

Function Akhir()
'By Yopibest�2009
Dim str As String, strArr() As String
Dim Int1 As Integer, Int2 As Integer
str = Replace(Selection.Address, "$", "")
strArr = Split(str, ":")
Int1 = AscW(UCase(Mid$(strArr(1), 1, 1)))
Int2 = AscW(UCase(Mid$(strArr(1), 2, 1)))
If Int1 <= 90 And Int1 >= 65 Then
If Int2 <= 90 And Int2 >= 65 Then
Akhir = Chr(Int1) & Chr(Int2)
Else
Akhir = Chr(Int1)
End If
End If
End Function

Sub Salah()
MsgBox "Tabel harus dibuat dibawah baris ke-5." & vbCrLf & _
"Sehingga ada minimal 5 baris kosong diatas tabel." & vbCrLf & vbCrLf & _
"Atau 5 baris paling atas dari posisi tabel, tidak boleh berisi." & vbCrLf & _
"Karena ini akan diisi oleh KOP surat.", vbInformation, "Anda Keliru !!!!!!"
Windows("MacroKop.xls").Close
End Sub

Jika mendownload MacroKop.zip, disana ada petunjuknya. Silakan dicoba.

PS: jangan lupa, hasil download-nya di ekstrak dulu.

2 komentar:

Aneh! mengatakan...

Mas, bikin macro untuk backup dokumen yah.

Yopibest mengatakan...

Untuk backup tinggal lakukan Save As menggunakan macro.
Kayak gini misalnya:

Dim tgl
tgl = Format(Date, "long date")
tgl = "Backup on " & tgl & " of " & ActiveWorkbook.Name
ActiveWorkbook.SaveAs _
FileName:=tgl, FileFormat:=xlNormal

Dengan catatan: macro ini sebaiknya dijadikan global template :)

Posting Komentar