Re: ]] XL-mania [[ summary dari beberapa work books dalam 1 folder

 

jadi... maksod loh ... eh maksod-nya.... :
tabel yg ingin digabung hanya tabel dalam sheets yg ada di workbook bernama "X"
dimana X adalah string yg dimulai dengan ANGKA SPASI STRIP misal "145 -"
dan diakhiri oleh 4 karakter ".xls"

kalo gitu kita akan saring dulu files yg berada SeFOLDER dengan file utama (summary.xls)
folder ini oleh makro dikenali sebagai (ThisWorkbook.Path) di mana pun anda meletakkannya..

hasil penyaringan harus memenuhi keinginan tsb diatas, yaitu berupa nama nama file
yg POLANYA  = "000000 - *.xls"
dengan "000000" adalah angka yg nilainya minimum 0; maximum = 999999999999999

hasil penyaringan sebaiknya berupa array string nama-nama file (yg memenuhi syarat)
dan ..... harus SORTED ascending.!!! supaya ketika digabung tidak ter-balik-bolak urutannnya..
(ini gampang; karena akan dikerjakan oleh sebuah UDF (atau FBD / made in dalam negeri)
bernama MatchFileList )

berdasarkan daftar itu-LAH kita membukai file-file tsb satu persatu
setiap terbuka satu file kita ambil datanya, lalu kita tempelkan di sheet 'detail' maupun 'kepala'
di workbook SUMMARY.XLS
cara mengambil maupun menempel tentunya harus sesuai aturan yg dikehendaki oom tomz itu
setelah satu file selesai "dikerjain" musti kudu ditutup untuk selanjutnya membuka file berikutnya...

selain itu masih ada pekerjaan kecil, yaitu mengubah data ex kolom URUTAN yg dari sumbernya
selalu "0001" kita ubah menjadi sesuai "angka nama workbook" yg sedang dibuka.

mudah mudahan coding ini ndak terlalu nguawurr...

-ctv-

'-----------coding list -----------------------
Sub GabungTabels()
'  +------------------------------------+
'  |  mengCopy Tabel dari books yg      |
'  |     memenuhi kriteria              |
'  |  ke sheet Gabung di workbook ini   |
'  |  sitiVi © modified 5 juli 2010     |
'  +------------------------------------+
'  |  for XL-mania, OnBehalfOf tomz     |
'  +------------------------------------+

   Dim BookNames As Variant
   Dim ReadTbl   As Range
   Dim WriteTo   As Range
   Dim ShtN      As String
   Dim Recs      As String
   Dim iBook     As Integer
   Dim TblHeig   As Long
   Dim n         As Long, i As Long
   Dim AngkaBook As String
  
   With Application
      .Calculation = xlCalculationManual
      .ScreenUpdating = False
      .DisplayAlerts = False
   End With
  
   HapusDataHasilGabung
  
   Set WriteTo = Sheets("detail").Range("A2")
   ThisWorkbook.Activate: WriteTo.Parent.Activate
   BookNames = MatchFileList()
  
   '-- proses menyalin tabel tiap sheets/book ke sheet 'details'
   n = 1
   For iBook = 1 To UBound(BookNames)
      Workbooks.Open ThisWorkbook.Path & "\" & BookNames(iBook)
      AngkaBook = Mid(BookNames(iBook), 1, InStr(1, BookNames(iBook), " ") - 1)
      Set ReadTbl = Workbooks(BookNames(iBook)).Sheets("detail").Range("A2")
      If Not ReadTbl(1, 1) = "" Then
         Set ReadTbl = Range(ReadTbl, ReadTbl.End(xlDown))
         Set ReadTbl = Range(ReadTbl, ReadTbl.End(xlToRight))
      End If
      TblHeig = ReadTbl.Rows.Count
      ReadTbl.Copy
      WriteTo(n, 1).PasteSpecial xlPasteValuesAndNumberFormats
     
      ' -- mengganti NOMOR-URUTAN sesuai nama book
      For i = n To n + TblHeig - 1
         WriteTo(i, 1).NumberFormat = "@"
         WriteTo(i, 1) = CStr(Right("0000" & AngkaBook, 4))
      Next
      n = n + TblHeig
     
      '-- proses menyalin tabel tiap sheets/book ke sheet 'kepala'
      '   termasuk mengganti "NOMOR-URUTAN"nya
      Workbooks(BookNames(iBook)).Sheets("kepala").Range("B2:D2").Copy
      With ThisWorkbook.Sheets("kepala").Range("A1")
        .Offset(iBook, 1).PasteSpecial xlPasteValuesAndNumberFormats
        .Offset(iBook, 0).NumberFormat = "@"
        .Offset(iBook, 0) = CStr(Right("0000" & AngkaBook, 4))
      End With
     
      ' - mencatat info tabel yg disalin
      Recs = Right(String(10, "_") & Str(TblHeig), 10)
      ShtN = ShtN & iBook & vbTab & "Book : " & BookNames(iBook) & _
             vbTab & Recs & "   records." & Space(6) & vbCr
      Workbooks(BookNames(iBook)).Close
   Next iBook
  
   WriteTo.CurrentRegion.Columns.AutoFit
   With Application
      .Calculation = xlCalculationAutomatic
      .ScreenUpdating = True
      .DisplayAlerts = True
   End With
   Range("A1").Activate
  
   '--saatnya laporan ke boss !!---
   MsgBox " T E L A H   D I P R O S E S :  " & n - 1 & " records  :" _
   & vbCr & vbCr & ShtN & vbCr & "Ya - Gitu - deh ... ", 64, _
   "©tv_Penggabungan Tabel² ke 1 Sheet"
 
 End Sub
'---------------end of coding list -----------------------

note
**coding ini belum sempat di "refine" jadi mungkin masih ada variebles nganggur,
blok yg tidak terlalu perlu dsb... saya yakin anda dapat me-refined-nya sendiri..
**member yg server emailnya menolak file zip, dan memerlukan file lampiran posting ini
(kalok mau!) dapat minta langsung file yg belum dikompress dari siti... via japri saja...

2010/6/28 Tommy <tomz.zlow@gmail.com>

Dear jawara excel,

 

saya punya masalah dengan banyaknya data yang harus di-review satu persatu dan di-input satu persatu dan kemudian baru dikirim ke orang jakarta (untungnya bukan satu per-satu).. masalah sering terjadi saat proses input -- jika saya tidak punya waktu untuk review satu persatu..

 

kriteria file yang akan di-summarize-kan:

-nama file selalu diawali dengan angka&" " &"-" (angka, spasi, garis tengah) yang menunjukkan urutan entry (nantinya akan ada perubahan dari data asli ke summary berdasarkan nomor urutan ini) bisa mencapai angka ratusan

-memiliki jumlah tabsheets yang sama dan memiliki headers yang sama

 

p.s: selain file yang mau di-summarize-kan, biasanya ada file excel lain yang namanya tidak di-awali dengan angka..

 

silahkan lihat contoh sederhana pada file terlampir..

 

terima kasih banyak, thank you very much, arigato, gracias, obrigado, matur nuwun sanget..,

 

blessings,

tomz

__._,_.___

Reply to sender | Reply to group | Reply via web post | Start a New Topic

Messages in this topic (2)

Recent Activity:

• New Members 93

Visit Your Group

+-:: XL-mania ::::::::::::::::::::----------------------------------+
| jangan lupa sebelum bertanya, cek dulu www.XL-mania.com dan       |
| http://tech.groups.yahoo.com/group/XL-mania/messages              |
| 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

Stay on top of your group activity without leaving the page you're on - Get the Yahoo! Toolbar now.

---

Get great advice about dogs and cats. Visit the Dog & Cat Answers Center.

---

Hobbies & Activities Zone: Find others who share your passions! Explore new interests.

Switch to: Text-Only, Daily Digest • Unsubscribe • Terms of Use

.

__,_._,___