macros
Example heading with h2 size
Example heading with h3 size
Following is sample java code.
Sub BuatSheetTokoBuka()
Dim ws As Worksheet
Dim newWs As Worksheet
Dim uniqueValues As Collection
Dim cell As Range
Dim outputRow As Integer
Dim tokoRange As Range
Dim colToCheck As String
Dim countDict As Object
Dim headerText As Variant
Dim i As Integer
' Ganti dengan kolom yang berisi nama toko
colToCheck = "E" ' Misal kolom E
' Menggunakan sheet yang sedang aktif
Set ws = ActiveSheet
Set tokoRange = ws.Range(colToCheck & "1:" & colToCheck & ws.Cells(ws.Rows.Count, colToCheck).End(xlUp).Row)
' Ambil teks dari A3:C4 untuk ditampilkan di atas tabel
headerText = ws.Range("A3:C4").Value ' Mengambil nilai dari rentang A3:C4
' Buat koleksi untuk menyimpan nilai unik
Set uniqueValues = New Collection
Set countDict = CreateObject("Scripting.Dictionary") ' Dictionary untuk menghitung kemunculan
On Error Resume Next ' Mengabaikan kesalahan saat menambahkan nilai duplikat
' Loop untuk mendapatkan nilai unik dari kolom yang ditentukan
For Each cell In tokoRange
If cell.EntireRow.Hidden = False Then ' Hanya ambil jika baris tidak tersembunyi
' Menambahkan nilai unik ke koleksi dan menghitung kemunculan
If Not countDict.exists(cell.Value) Then
countDict.Add cell.Value, 1 ' Tambahkan toko baru
uniqueValues.Add cell.Value ' Tambahkan ke koleksi unik
Else
countDict(cell.Value) = countDict(cell.Value) + 1 ' Increment count
End If
End If
Next cell
On Error GoTo 0 ' Menghentikan pengabaian kesalahan
' Buat sheet baru
Set newWs = ThisWorkbook.Sheets.Add
newWs.Name = "Toko Buka" ' Nama sheet baru
' Tulis header yang diambil dari A3:C4
For i = LBound(headerText, 2) To UBound(headerText, 2)
newWs.Cells(3, i).Value = headerText(1, i) ' Menulis baris 3 (A3, B3, C3)
newWs.Cells(4, i).Value = headerText(2, i) ' Menulis baris 4 (A4, B4, C4)
Next i
' Format header untuk tanggal dan outlet
With newWs.Range("A3:C4")
.Font.Bold = True
.Font.Size = 12
.HorizontalAlignment = xlLeft ' Rata kiri untuk header tanggal dan outlet
.VerticalAlignment = xlCenter
.RowHeight = 25 ' Tinggi baris
.EntireRow.AutoFit ' Menyesuaikan tinggi baris
End With
' Tulis header tabel
newWs.Cells(5, 1).Value = "Toko"
newWs.Cells(5, 2).Value = "Jumlah"
' Format header tabel
With newWs.Range("A5:B5")
.Font.Bold = True
.Font.Size = 15
.Interior.Color = RGB(0, 0, 0) ' Warna latar belakang hitam
.Font.Color = RGB(255, 255, 255) ' Warna font putih
.HorizontalAlignment = xlCenter ' Rata tengah
.RowHeight = 25 ' Tinggi baris
End With
' Tulis nilai unik dan jumlah ke dalam sheet baru
outputRow = 6 ' Mulai dari baris keenam untuk data
For Each Item In uniqueValues
newWs.Cells(outputRow, 1).Value = Item
newWs.Cells(outputRow, 2).Value = countDict(Item) ' Mengambil jumlah dari dictionary
outputRow = outputRow + 1
Next Item
' Format data
With newWs.Range("A6:B" & outputRow - 1)
.Font.Size = 12
.Borders.LineStyle = xlContinuous ' Tambahkan border
.Borders.Weight = xlThin
.Interior.Color = RGB(255, 255, 255) ' Warna latar belakang putih
.VerticalAlignment = xlCenter ' Rata tengah vertikal
.HorizontalAlignment = xlCenter ' Rata tengah horizontal
.Font.Bold = True ' Membuat teks menjadi tebal
.RowHeight = 25 ' Tinggi baris
End With
' Sesuaikan lebar kolom
newWs.Columns("A").AutoFit
newWs.Columns("B").AutoFit
' Tambahkan border ke seluruh tabel
With newWs.Range("A5:B" & outputRow - 1)
.Borders.LineStyle = xlContinuous
.Borders.Weight = xlThin
End With
' Tambahkan peringatan di bawah tabel
newWs.Cells(outputRow, 1).Value = "Periksa Kembali dengan Label karena ini dibuat dengan sistem. Masih bisa terjadi kesalahan!"
With newWs.Cells(outputRow, 1)
.Font.Size = 8 ' Ukuran font kecil
.Font.Bold = False ' Tidak tebal
.HorizontalAlignment = xlLeft ' Rata kiri
.VerticalAlignment = xlCenter
.RowHeight = 20 ' Tinggi baris untuk peringatan
End With
MsgBox "Sheet baru telah dibuat dengan nama 'Toko Buka' yang berisi nilai unik dan jumlahnya."
End Sub
--------------------------------
Sub HideKolomBarisMultipleSheets()
Dim ws As Worksheet
Dim lastRow As Long
Dim lastCol As Long
Dim i As Long
Dim j As Long
Dim isRowEmpty As Boolean
Dim isColEmpty As Boolean
Dim cellValue As Variant
' Loop melalui semua sheet yang dipilih
For Each ws In Application.ActiveWindow.SelectedSheets
' Gunakan sheet yang sedang diproses dalam loop
ws.Activate
' Menentukan baris terakhir berdasarkan kolom F
lastRow = ws.Cells(ws.Rows.Count, "F").End(xlUp).Row
' Menentukan kolom terakhir berdasarkan baris 12
lastCol = ws.Cells(12, ws.Columns.Count).End(xlToLeft).Column
' FUNGSI BARIS
' Menyembunyikan baris yang isinya 0 (baik string maupun angka 0)
For i = 12 To lastRow
isRowEmpty = True
' Memeriksa setiap kolom dari F hingga kolom terakhir
For j = 6 To lastCol ' Kolom F adalah kolom ke-6
' Ambil nilai sel
cellValue = ws.Cells(i, j).Value
' Memeriksa jika nilai sel adalah 0 (angka) atau "0" (string)
If Len(Trim(cellValue)) <> 0 And cellValue <> 0 And cellValue <> "0" Then
isRowEmpty = False
Exit For ' Keluar jika menemukan nilai non-0
End If
Next j
' Jika semua sel di baris ini adalah 0, sembunyikan baris
If isRowEmpty Then
ws.Rows(i).Hidden = True
End If
Next i
' FUNGSI KOLOM
' Menyembunyikan kolom yang isinya 0 (baik string maupun angka 0)
For j = lastCol To 6 Step -1 ' Mulai dari kolom terakhir
isColEmpty = True
' Memeriksa setiap baris dari baris 12 hingga baris terakhir
For i = 12 To lastRow
' Ambil nilai sel
cellValue = ws.Cells(i, j).Value
' Memeriksa jika nilai sel adalah 0 (angka) atau "0" (string)
If Len(Trim(cellValue)) <> 0 And cellValue <> 0 And cellValue <> "0" Then
isColEmpty = False
Exit For ' Keluar jika menemukan nilai non-0
End If
Next i
' Jika semua sel di kolom ini adalah 0, sembunyikan kolom
If isColEmpty Then
ws.Columns(j).Hidden = True
End If
Next j
Next ws ' Lanjutkan ke sheet berikutnya yang dipilih
MsgBox "Proses penyembunyian baris dan kolom selesai untuk semua sheet yang dipilih!", vbInformation
End Sub
------------
Sub RearrangeColumnsInSameSheet()
Dim ws As Worksheet
Dim keepCols As Variant
Dim i As Long
Dim srcCol As Range
Dim destCol As Long
Dim header As String
Dim tempWs As Worksheet
' Menentukan urutan kolom yang diinginkan
keepCols = Array("SubOutlet Code", "SubOutlet Name", "Rit", "Gate", "No.Invoice", "Tanggal Kirim", _
"10004037", "10008867", "20037475", "10018154", "", "20003591", "20108264*", _
"20120460", "20109047", "", "20123203", "20055855", "20108264", "20132623", _
"20120972", "20132625", "20035999", "20046107", "20036000", "20046106", _
"20074234", "20052495", "20074235", "20086834", "20132616", "20132618", _
"20132619", "20134379", "10004039", "10032089", "", "20118139", "10004372", _
"20003593", "10004371", "20136101", "20062099", "20130215", "20130214", "", "20133258", _
"20125603", "20125604", "20125605", "20025041", "10010256", "10006194X", _
"10006195X", "10005643X", "20014916X", "", "10006194", "10006195", _
"10005643", "20014916", "20031087", "20118513", "20136106", "20028241", "", "", _
"20082692", "20127599", "", "", "20132621", "20135250", "20091744", _
"20091743", "", "20072596", "20080782", "20126866", "20126869", _
"20126870", "20126867", "Total Crate Tawar", "Total Crate Manis", "NO PO")
' Iterasi melalui setiap worksheet yang terpilih
For Each ws In Application.ActiveWindow.SelectedSheets
If ws.Visible = xlSheetVisible Then
' Menambahkan sheet sementara untuk menyusun ulang kolom
Set tempWs = Worksheets.Add
destCol = 1 ' Kolom tujuan di sheet sementara
' Iterasi melalui setiap elemen dalam keepCols
For i = LBound(keepCols) To UBound(keepCols)
header = Trim(CStr(keepCols(i))) ' Pastikan semua elemen adalah string dan trim spasi
' Mencari kolom sumber berdasarkan header
Set srcCol = ws.Rows(1).Find(What:=header, LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False)
If Not srcCol Is Nothing Then
' Menyalin kolom ke sheet sementara
ws.Columns(srcCol.Column).Copy
tempWs.Cells(1, destCol).PasteSpecial Paste:=xlPasteAll
Application.CutCopyMode = False
Else
' Jika kolom tidak ditemukan, tambahkan header saja
tempWs.Cells(1, destCol).Value = header
End If
destCol = destCol + 1
Next i
' Hapus semua kolom di sheet asli
ws.Cells.Clear
' Salin ulang data dari sheet sementara ke sheet asli
tempWs.UsedRange.Copy ws.Cells(1, 1)
' Hapus sheet sementara
Application.DisplayAlerts = False
tempWs.Delete
Application.DisplayAlerts = True
' Menyesuaikan lebar kolom
ws.Columns.AutoFit
End If
Next ws
MsgBox "Proses penyusunan ulang kolom selesai!", vbInformation
End Sub
-------------------------------------------------------------------------
Sub ModifyActiveSheet()
Dim ws As Worksheet
Set ws = ActiveSheet
' 1. Ganti font di semua sheet aktif dengan Franklin Gothic Medium ukuran 10
ws.Cells.Font.Name = "Franklin Gothic Medium"
ws.Cells.Font.Size = 10
ws.Cells.Font.Bold = False ' Pastikan tidak bold
' 2. Ubah ukuran font di baris 9-11 menjadi 8
ws.Rows("9:11").Font.Size = 8
' 3. Ubah ukuran font di range F12:EK804 menjadi 12
ws.Range("F12:EK804").Font.Size = 12
' 4. Merge and center A804:E804 dan ubah ukuran font menjadi 24
With ws.Range("A804:E804")
.Merge
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.Font.Size = 24
.Font.Bold = False ' Pastikan tidak bold
End With
' 5. Ubah format baris 804 menjadi General
ws.Rows(804).NumberFormat = "General"
' 6. Ubah lebar kolom AI sampai EI menjadi 5.5
ws.Range("AI:EI").ColumnWidth = 5.5
' 7. Ubah lebar kolom F sampai AD menjadi 5.5
ws.Range("F:AD").ColumnWidth = 5.5
' Tambahan:
' 1. Ubah lebar kolom A & B menjadi 5.5
ws.Columns("A:B").ColumnWidth = 5.5
' 2. Ubah lebar kolom C menjadi 24
ws.Columns("C").ColumnWidth = 24
' 3. Ubah lebar kolom AE dan AH (AE = 8, AH = 12)
ws.Columns("AE").ColumnWidth = 8
ws.Columns("AH").ColumnWidth = 12
' 4. Ubah lebar kolom EJ dan EK (EJ = 8, EK = 12)
ws.Columns("EJ").ColumnWidth = 8
ws.Columns("EK").ColumnWidth = 12
End Sub