Hot Fox: Re: ]] XL-mania [[ copy data dari banyak file dalam satu folder

quinta-feira, 17 de dezembro de 2009

Re: ]] XL-mania [[ copy data dari banyak file dalam satu folder

Sub GabungTabelSheets()
   '-------------------------------------------------------'
   '=== prosedur menggabung beberapa sheet ke satu sheet =='
   '=== siti / untuk milis XL-mania / 17 dec 2009=========='
   '-------------------------------------------------------'
   Dim Newbook As Workbook
   Dim OpenBook As Workbook
   Dim NewSheet As Worksheet
   Dim Ws       As Worksheet
   Dim MoveTbl As Range
   Dim DestRng As Range
   Dim SheetN_Set As Long
   Dim Sht_Rows   As Long
   Dim MoveRows   As Long
   Dim WsN As Long
   Dim N    As Long
   Dim sN   As Integer
   Dim x    As Integer
   Dim WbN As Integer

   SheetN_Set = Application.SheetsInNewWorkbook
   Application.SheetsInNewWorkbook = 1
   Set Newbook = Workbooks.Add
   Newbook.SaveAs Filename:=ThisWorkbook.Path & "\New" & Newbook.Name
   Set NewSheet = ActiveSheet
   Application.SheetsInNewWorkbook = SheetN_Set
   Set DestRng = NewSheet.Range("A1")
   Filist = FNameList("csv")

   ' Application.ScreenUpdating = False

   For WbN = 1 To UBound(Filist)
      Workbooks.Open Filename:=ThisWorkbook.Path & "\" & Filist(WbN)
      Set OpenBook = ActiveWorkbook
      Windows(ThisWorkbook.Name).Activate
      N = 0

      For Each Ws In OpenBook.Worksheets

OnSheetIsFull:
         sN = sN + 1: WsN = WsN + 1
         If sN = 1 Then
            Set MoveTbl = Ws.Range("A1").CurrentRegion
            Set MoveTbl = MoveTbl.Offset(0, 5).Resize(MoveTbl.Rows.Count, 1)
            x = -1
         ElseIf sN > 1 Then
            Set MoveTbl = Ws.Range("A1").CurrentRegion.Offset(1, 5)
            Set MoveTbl = MoveTbl.Resize(MoveTbl.Rows.Count - 1, 1)
            x = 0
         End If

         MoveRows = MoveTbl.Rows.Count + x
         Sht_Rows = Sht_Rows + MoveRows

         If Sht_Rows >= 2 ^ 16 - 1 Then
            Windows(Newbook.Name).Activate
            Set NewSheet = Newbook.Worksheets.Add
            Set DestRng = NewSheet.Range("A1")
            NewSheet.Move After:=Sheets(Sheets.Count)
            Sht_Rows = 0: sN = 0:
            WsN = WsN - 1
            Application.CutCopyMode = False
            GoTo OnSheetIsFull
         End If

         With ThisWorkbook.Sheets("interface").Range("B7")
            .Cells(WsN, 0) = WbN
            .Cells(WsN, 1) = Filist(WbN)
            .Cells(WsN, 2) = Ws.Name
            .Cells(WsN, 3) = MoveRows
            .Cells(WsN, 4) = Newbook.Name
            .Cells(WsN, 5) = NewSheet.Name
         End With

         MoveTbl.Copy
         DestRng.PasteSpecial xlPasteValues
         Set DestRng = DestRng.Offset(MoveRows, 0)
         N = N + CLng(MoveRows)
      Next Ws
      Application.CutCopyMode = False
      OpenBook.Close
   Next WbN

   ' Application.ScreenUpdating = True
   ThisWorkbook.Sheets("interface").Activate
   [C4] = "generated on: " & Format(Now, "dd-mmm-yyyy hh:mm:ss")
   [B4].Select
   MsgBox "Selesai ! " & vbCrLf & WbN - 1 & " sheets telah digabung;" & vbCrLf & _
   "Silakan " & Newbook.Name & " di save lagi", vbInformation, "LAPORAN..."
End Sub

notes:

Set MoveTbl = Ws.Range("A1").CurrentRegion.Offset(1, 5)
Set MoveTbl = MoveTbl.Resize(MoveTbl.Rows.Count - 1, 1)
mengindikasikan bahwa MoveTbl mengambil data di tiap sheet

hanya 1 kolom data di kolom ke 6 saja (offset kolom 5 dihitung dari A = 0)

Prosedur di atas perlu dibantu oleh UDF FNameList("NamaFileExtensi")

Udf tsb akan membuat array Daftar File Ex Folder di mana workbook utama (yg berisi makro) berada.

Gunanya, untuk memanggil file yg dikehendaki satu persatu melalui Loop.

For WbN = 1 To UBound(Filist)
Coding UDF lengkapnya silakan diihat di module 2

<> semoga bermanfaat...

----- Original Message -----
From: Effendi Wijaya
To: XL-mania@yahoogroups.com
Sent: Thursday, December 17, 2009 10:06 AM
Subject: ]] XL-mania [[ copy data dari banyak file dalam satu folder

Dear Pakar XL-Mania,
salam, malu bertanya kerja Manual,
Kenalkan saya adalah anggota pasif xl mania.
banyak masalah perexcelan yg telah terselesaikan melalui milis.
ini posting saya yg pertama setelah setahun bergabung, saya sudah coba tanya

mbah google, tapi belum dapat solusi.
kiranya pakar XL-disni bisa memberikan solusi yang ampuh "sakti mandraguna".
Case:
Saya punya data/file didalam 1 folder jumlah nya banyak sekali.
di dalam setiap file tersebut hanya ada satu sheet yang berisi data2.
saya ingin menggabungkan/copy data-data yang ada di kolom f saja tersebut

kedalam satu file/workbook saja.
sehingga sewaktu pencarian data akan sangat mudah hanya buka 1 file/workbook.
Kondisi
-File/data yg akan di copy berextension CSV
-Jika sheet1 pada workbook gabungan/tujuan sudah full, maka data akan di letakan

di sheet2,sheet3 dst.
trimakasih pada pakar yg bisa memberikan solusi,mudah-mudahan amal nya

di balas lebih....

file contoh terlampir.

Salam
Effendi Wijaya

__._,_.___

Reply to sender | Reply to group

Messages in this topic (5)

Recent Activity:

New Members 76

Visit Your Group Start a New Topic

+-:: XL-mania ::::::::::::::::::::----------------------------------+
| Ini work-load atau work-flood ya? ada lowongan jadi direktur?     |
| 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

Going Green: Your Yahoo! Groups resource for green living