=================================================
EXCEL & VBA TUTORIAL | MODUL APLIKASI
=================================================
Sub ExportDataPerSales()
Dim wsDatabase As Worksheet, wbNew As Workbook
Dim lastRow As Long, lastCol As Long
Dim dict As Object
Dim rng As Range, cell As Range
Dim salesName As Variant
Dim wsSales As Worksheet, rngCopy As Range
Dim outputPath As String
Dim headerRange As Range
Set wsDatabase = ThisWorkbook.Sheets("DATABASE")
lastRow = wsDatabase.Cells(wsDatabase.Rows.Count, 2).End(xlUp).Row
lastCol = wsDatabase.Cells(5, wsDatabase.Columns.Count).End(xlToLeft).Column
Set headerRange = wsDatabase.Range("A5", wsDatabase.Cells(5, lastCol))
Set dict = CreateObject("Scripting.Dictionary")
For Each cell In wsDatabase.Range("B6:B" & lastRow)
salesName = Trim(cell.Value)
If salesName <> "" And Not dict.exists(salesName) Then
dict.Add salesName, Nothing
End If
Next cell
Set wbNew = Workbooks.Add
Application.DisplayAlerts = False
Do While wbNew.Sheets.Count > 1
wbNew.Sheets(1).Delete
Loop
Application.DisplayAlerts = True
For Each salesName In dict.keys
Set wsSales = wbNew.Sheets.Add
wsSales.Name = salesName
headerRange.Copy
wsSales.Range("A1").PasteSpecial Paste:=xlPasteValues
wsDatabase.Range("A5").AutoFilter Field:=2, Criteria1:=salesName
Set rngCopy = wsDatabase.Range("A6:A" & lastRow).Resize(,
lastCol).SpecialCells(xlCellTypeVisible)
If Not rngCopy Is Nothing Then
rngCopy.Copy
wsSales.Range("A2").PasteSpecial Paste:=xlPasteValues
End If
wsDatabase.AutoFilterMode = False
Next salesName
outputPath = ThisWorkbook.Path & "\Data Sales-" & Format(Now(), "DDMMYYYY") &
".xlsx"
wbNew.SaveAs outputPath
wbNew.Close SaveChanges:=False
MsgBox "Export selesai! File tersimpan di: " & outputPath, vbInformation,
"Sukses"
End Sub
Sub SimpanTarget()
Dim DBtarget As Object
Set DBtarget = Sheet3.Range("A10000").End(xlUp)
If Sheet1.Range("C6").Value = "" _
Or Sheet1.Range("C10").Value = "" _
Or Sheet1.Range("C14").Value = "" _
Or Sheet1.Range("C18").Value = "" _
Or Sheet1.Range("C22").Value = "" _
Or Sheet1.Range("C26").Value = "" _
Or Sheet1.Range("C30").Value = "" _
Or Sheet1.Range("C34").Value = "" Then
Call MsgBox("Harap isi data target dengan lengkap", vbInformation, "Data Target")
Else
DBtarget.Offset(1, 0).Value = Sheet1.Range("C6").Value
DBtarget.Offset(1, 1).Value = Sheet1.Range("C10").Value
DBtarget.Offset(1, 2).Value = Sheet1.Range("C14").Value
DBtarget.Offset(1, 3).Value = Sheet1.Range("C18").Value
DBtarget.Offset(1, 4).Value = Sheet1.Range("C22").Value
DBtarget.Offset(1, 5).Value = Sheet1.Range("C26").Value
DBtarget.Offset(1, 6).Value = Sheet1.Range("C30").Value
DBtarget.Offset(1, 7).Value = Sheet1.Range("C34").Value
Call SimpanDataKeDatabase
'Sheet1.Range("C6").Value = ""
'Sheet1.Range("C10").Value = ""
Sheet1.Range("C14").Value = ""
Sheet1.Range("C18").Value = ""
'Sheet1.Range("C22").Value = ""
'Sheet1.Range("C26").Value = ""
'Sheet1.Range("C30").Value = ""
'Sheet1.Range("C34").Value = ""
End If
End Sub
Sub SimpanDataKeDatabase()
Dim wsDashboard As Worksheet, wsDatabase As Worksheet
Dim rngSumber As Range, rngTujuan As Range, rngTanggal As Range
Dim barisTujuan As Long, jumlahBaris As Long
Dim tanggalSumber As String
' Set worksheet
Set wsDashboard = ThisWorkbook.Sheets("DASHBOARD")
Set wsDatabase = ThisWorkbook.Sheets("DATABASE")
' Ambil tanggal dari DASHBOARD!C33
tanggalSumber = Format(CDate(wsDashboard.Range("C10").Value), "MM/DD/YYYY")
' Set range sumber (data yang akan disimpan)
Set rngSumber = wsDashboard.Range("F7:P21")
If wsDashboard.Range("Q22").Value = 0 Then
Call MsgBox("Tidak ada transaksi yang disimpan", vbExclamation, "Simpan
Transaksi")
Else
' Hitung jumlah baris yang akan disimpan (berdasarkan data di kolom pertama
dari range sumber)
jumlahBaris = Application.CountA(rngSumber.Columns(1))
' Cari baris kosong pertama di sheet DATABASE mulai dari baris ke-5
barisTujuan = wsDatabase.Cells(wsDatabase.Rows.Count, 6).End(xlUp).Row + 1
If barisTujuan < 5 Then barisTujuan = 5 ' Pastikan data dimulai dari baris ke-5
' Set range tujuan
Set rngTujuan = wsDatabase.Cells(barisTujuan, 2)
' Salin data dari DASHBOARD ke DATABASE
rngSumber.Copy
rngTujuan.PasteSpecial Paste:=xlPasteValues
' Tambahkan tanggal dari DASHBOARD!C33 ke kolom A sesuai jumlah baris yang
disimpan
Set rngTanggal = wsDatabase.Range("A" & barisTujuan & ":A" & barisTujuan +
jumlahBaris - 1)
rngTanggal.Value = tanggalSumber
' Hapus data dari DASHBOARD setelah disimpan
wsDashboard.Range("G7:P21").ClearContents
' Hapus clipboard
Application.CutCopyMode = False
' Notifikasi bahwa data telah disimpan
MsgBox "Data berhasil disimpan ke DATABASE dengan tanggal " & tanggalSumber &
"!", vbInformation, "Sukses"
End If
End Sub
Sub FullScreen()
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
.ExecuteExcel4Macro "show.toolbar(""Ribbon"",False)"
.WindowState = xlMaximized
.CommandBars("Full Screen").Visible = False
.CommandBars("Worksheet Menu Bar").Enabled = False
.DisplayStatusBar = False
.DisplayScrollBars = False
.DisplayFormulaBar = False
End With
With ActiveWindow
.DisplayWorkbookTabs = False
.DisplayRuler = False
.DisplayHeadings = False
End With
With Application
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
End With
End Sub
Sub Normal()
With Application
.ScreenUpdating = True
.Calculation = xlCalculationManual
.ExecuteExcel4Macro "show.toolbar(""Ribbon"",True)"
.WindowState = xlMaximized
.CommandBars("Full Screen").Visible = True
.CommandBars("Worksheet Menu Bar").Enabled = True
.DisplayStatusBar = True
.DisplayScrollBars = True
.DisplayFormulaBar = True
End With
With ActiveWindow
.DisplayWorkbookTabs = True
.DisplayRuler = True
.DisplayHeadings = True
End With
With Application
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
End With
End Sub
