Hot Fox: Re: ]] XL-mania [[ Rekap Data dari beberapa folder

terça-feira, 3 de novembro de 2009

Re: ]] XL-mania [[ Rekap Data dari beberapa folder

Om om om ,.......kodingannya kayak gini nih oom ........
(

Awas kalo banyak terlalu ngatur nanti kayak Anggodo )

' --------------------------------------------------------------------
' Nama Modul :ModSolusi.mod
' Kegunaan : Solusinya si oom
' Created By : puthut_vai@yahoo.com @ 4 Nop 2009
' --------------------------------------------------------------------

Dim Folder As Scripting.Folder
Dim SubFolder As Scripting.Folder
Dim File As Scripting.File
Dim FSO As Scripting.FileSystemObject

Sub SolusiSioomm()
    Dim Path As String, vWorkBuk As String
    Dim wShitHasilKopian As Worksheet, ws As Worksheet
    Dim fileName As String, vWBukdiSubFolder As Workbook
    Dim vRangeKopian As Range, vRangeHasilKopian As Range
    Dim vBarisKopian As Integer

    vBarisKopian = 2 ' Mulai Baris

    vWorkBuk = ActiveWorkbook.Name

    Path = ThisWorkbook.Path

    Application.EnableEvents = False
    Application.ScreenUpdating = False

    ' Make Pisual Besik Skrip.......
    Set FSO = New Scripting.FileSystemObject
    Set Folder = FSO.GetFolder(folderpath:=Path)

    ' Cek File di Sib Polder....
    For Each SubFolder In Folder.SubFolders

    ' Make Wild Card....
    ' Wild artinya : Liar
    ' Card : Kartu
    ' Jadi Wild Card = Kartu Liar,....ha ha ha ha.........
    ' = Looping semua dengan extensi File xls di dalam subdolder.....
    fileName = Dir(SubFolder & "\*.xls", vbNormal)
    If Len(fileName) = 0 Then Exit Sub
    ' Looping File di Subfolder
    Do Until fileName = vbNullString
        If Not fileName = vWorkBuk Then
            ' Untuk Data Penjualan
            If fileName = "Data Penjualan.xls" Then
                Set wShitHasilKopian = ActiveWorkbook.Sheets("sales")
                Set vWBukdiSubFolder = Workbooks.Open(fileName:=SubFolder & "\" & fileName)
                Set vRangeKopian = vWBukdiSubFolder.Sheets(1).Range(Cells(vBarisKopian, 1), Cells(ActiveSheet.UsedRange.Rows.Count, ActiveSheet.UsedRange.Columns.Count))
                Set vRangeHasilKopian = wShitHasilKopian.Range("A" & wShitHasilKopian.UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1)
                vRangeKopian.Copy vRangeHasilKopian
                vWBukdiSubFolder.Close False
            ' Barang Hilang
            ElseIf fileName = "Barang Hilang.xls" Then
                Set wShitHasilKopian = ActiveWorkbook.Sheets("lost")
                Set vWBukdiSubFolder = Workbooks.Open(fileName:=SubFolder & "\" & fileName)
                Set vRangeKopian = vWBukdiSubFolder.Sheets(1).Range(Cells(vBarisKopian, 1), Cells(ActiveSheet.UsedRange.Rows.Count, ActiveSheet.UsedRange.Columns.Count))
                Set vRangeHasilKopian = wShitHasilKopian.Range("A" & wShitHasilKopian.UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1)
                vRangeKopian.Copy vRangeHasilKopian
                vWBukdiSubFolder.Close False
            ' Pelanggan
             ElseIf fileName = "Data Pelanggan.xls" Then
                Set wShitHasilKopian = ActiveWorkbook.Sheets("customer")
                Set vWBukdiSubFolder = Workbooks.Open(fileName:=SubFolder & "\" & fileName)
                Set vRangeKopian = vWBukdiSubFolder.Sheets(1).Range(Cells(vBarisKopian, 1), Cells(ActiveSheet.UsedRange.Rows.Count, ActiveSheet.UsedRange.Columns.Count))
                Set vRangeHasilKopian = wShitHasilKopian.Range("A" & wShitHasilKopian.UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1)
                vRangeKopian.Copy vRangeHasilKopian
                vWBukdiSubFolder.Close False
            End If
        End If


        fileName = Dir() ' <--- Jangan diapa2xin bahaya bisa ngeheng.....
    Loop
    Next SubFolder

    Application.EnableEvents = True
    Application.ScreenUpdating = True

    Set Folder = Nothing
    Set FSO = Nothing
End Sub

File Terlampir oom....
Puthut Wibowo

--- On Mon, 11/2/09, ..:: priel ::.. <XAVREIL@GMAIL.COM> wrote:

From: ..:: priel ::.. <XAVREIL@GMAIL.COM>
Subject: ]] XL-mania [[ Rekap Data dari beberapa folder
To: XL-mania@yahoogroups.com
Date: Monday, November 2, 2009, 4:48 AM

Rekan XL-Mania

Nubie mau nanya nih, sekalian buat belajar ngolah data pake Excel. Saya lagi ada kerjaan untuk rekap data, dimana data tersebut di kumpulkan setiap hari, dan dipisah ke dalam folder yang berbeda. Tiap folder (nama folder mengindikasikan tanggal data tersebut dibuat) berisi nama file yang sama (lihat lampiran isi folder)

sedangkan struktur folder bisa dilihat pada lampiran folder structure - XL-Mania.jpg

yang bikin saya pegel, pada saat harus merekap data mingguan, apalagi bulanan. Karena nggak ngarti makro, terpaksa kerja manual (musuhnya XL-Mania nih.. ^_^). Untuk itu mohon dibantu, agar bisa dikasih contoh makronya. Rencananya adalah :
1. Rekap mingguan diambil dari 7 hari sebelumnya, berarti melibatkan 7 folder
2. Tiap file disusun dalam sheet yang berbeda
3. Disusun urut ke bawah, tiap tanggal ditandai dengan 1 baris kosong

Pada output, terdapat contoh hasil yang diinginkan.. . **halah.. keliatan banget malesnya, dah rewel, ngatur pula :-)**

Terima kasih sebelumnya buat rekan-rekan yang berseda membagi ilmunya

salam belajar Excel
priel

__._,_.___

Messages in this topic (3) Reply (via web post) | Start a new topic

Messages

+-:: XL-mania ::::::::::::::::::::----------------------------------+
| Pcas ndahe... pcas ndahe... pcas ndahe... pcas ndahe...           |
| http://www.facebook.com/group.php?gid=37671048001&ref=mf          |
+-------------------------------------------------------------------+
| DILARANG : MLM, money game, OOT, iklan tanpa izin, SARA, testing, |
| pembicaraan pribadi, one line message, melecehkan, tidak sopan. |
+-------------------------------------------------------------------+
| Buat subjek yang kreatif, jangan : "tanya", "help", "mohon bantu" |
| Usahakan besar attachment < 200 kb. Gunakan winzip jika perlu. |
+-------------------------------------------------------------------+
| Ajak teman-teman Anda bergabung dengan mengirim e-mail kosong ke |
| XL-mania-subscribe@yahoogroups.com atau kirimkan mereka file dari |
| http://groups.yahoo.com/group/XL-mania/files/Promotion/           |
+-------------------------------------------------------------------+
| Berikan testimoni di : http://www.friendster.com/xlmania atau... |
| http://www.xl-mania.com/2008/06/testimoni-xl-mania.html           |
+-------------------------------------------------------------------+
| Message lama ada di :                                             |
| http://groups.yahoo.com/group/XL-mania/messages [perlu yahoo id] |
| http://www.mail-archive.com/xl-mania@yahoogroups.com              |
+-------------------------------------------------------------------+

MARKETPLACE

Mom Power: Discover the community of moms doing more for their families, for the world and for each other