Re: ]] XL-mania [[ Mengelompokkan Sheet Berdasakan Salah Satu Kolom

 

Sub Du_Sam_Ting()

   '------------------------------

   ' siti Vi

   ' bluewater, 23 jun 2011

   '------------------------------

   Dim UnxFood(), AllData(), ArrShtNm()

   Dim CurRnge As Range, NewRnge As Range, NewHead As Range

   Dim NewBook As Workbook, CurBook As Workbook

   Dim ShtInBook As Integer, st As Integer

   Dim i As Long, n As Long, r As Long

   Dim FSO As Object, FOL As Object, F As Object

   Dim PathDirNm As String

   

   PathDirNm = ThisWorkbook.Path

   On Error GoTo akhir

   Set FSO = CreateObject("Scripting.FileSystemObject")

   Set FOL = FSO.GetFolder(PathDirNm).Files

   

   With Application

   .ScreenUpdating = False

   .Calculation = xlCalculationManual

   .EnableEvents = False

   ShtInBook = .SheetsInNewWorkbook

   

   For Each F In FOL

      If Left(F.Name, 2) = "20" Then

         st = st + 1

         ReDim Preserve ArrShtNm(1 To st)

         ArrShtNm(st) = Left(F.Name, InStr(1, F.Name, ".") - 1)

         Workbooks.Open ThisWorkbook.Path & "\" & F.Name

         Set CurRnge = Workbooks(F.Name).Sheets(1).Cells(1).CurrentRegion

         If st = 1 Then

            CurRnge.Resize(1, CurRnge.Columns.Count).Copy _

            ThisWorkbook.Sheets(1).Cells(50, 1)

            Set NewHead = ThisWorkbook.Sheets(1).Cells(50, 1). _

                          Resize(1, CurRnge.Columns.Count)

         End If

         For i = 2 To CurRnge.Rows.Count

            CurRnge.Select

            n = n + 1

            ReDim Preserve UnxFood(1 To n)

            UnxFood(n) = CurRnge(i, 2)

            ReDim Preserve AllData(1 To CurRnge.Columns.Count + 1, 1 To n)

            AllData(1, n) = CurRnge(i, 1)

            AllData(2, n) = CurRnge(i, 2)

            AllData(3, n) = Left(F.Name, InStr(1, F.Name, ".") - 1)

         Next i

         Workbooks(F.Name).Close SaveChanges:=False

      End If

   Next

   

akhir:

   UnxFood = LOUV(UnxFood)

   .SheetsInNewWorkbook = UBound(ArrShtNm)

   For i = LBound(UnxFood) To UBound(UnxFood)

      Set NewBook = Workbooks.Add

      For st = 1 To UBound(ArrShtNm)

         NewBook.Sheets(st).Name = ArrShtNm(st)

         NewHead.Copy NewBook.Sheets(st).Cells(1)

         Set NewRnge = NewBook.Sheets(st).Cells(2, 1)

         r = 0

         For n = LBound(AllData, 2) To UBound(AllData, 2)

            If AllData(2, n) = UnxFood(i) Then

               If AllData(3, n) = ArrShtNm(st) Then

                  r = r + 1

                  NewRnge(r, 1) = AllData(1, n)

                  NewRnge(r, 2) = AllData(2, n)

               End If

            End If

         Next n

      Next st

      NewBook.Close SaveChanges:=True, _

         Filename:=ThisWorkbook.Path & "\" & UnxFood(i)

   Next i

   

   ThisWorkbook.Sheets(1).Range("A50:B50").Clear

   Application.SheetsInNewWorkbook = ShtInBook

End Sub

'-----------------------------------

setelah selesai menjalankan makro, untuk mengetahui hasilnya buka folder nya

apakah ada penambahan file baru, dan apakah isinya sesuai ??

2011/6/22 akbar arsyad <akbar_arsyad@yahoo.co.id>

Dear All,

Saya mempunyai permasalahan, saya punya beberapa file, yaitu file tahun 2003.xls, 2004.xls, dan 2005.xls
Masing-masing berisi satu sheet, contohnya sbb:

-2003.xls
Kolom A    Kolom B
Binatang    Makanannya <<< Header
Kucing       Ikan
Anjing        Ikan
Kelinci       Wortel
Kuda         Rumput
Sapi          Rumput

-2004.xls
Kolom A    Kolom B
Binatang    Makanannya <<< Header
Kucing       Ikan
Anjing        Daging
Kelinci       Wortel
Kuda         Wortel
Sapi          Rumput

-2005.xls
Kolom A    Kolom B
Binatang   Makanannya <<< Header
Kucing      Daging
Anjing       Tulang
Kelinci      Rumput
Kuda        Rumput
Sapi         Jagung

 
Saya ingin menggenerate file2 yang judulnya berdasarkan makanannya, jadi ada file Ikan.xls, wortel.wls, rumput.xls, daging.xls, tulang.xls, dan jagung.xls.
Masing2 file terdiri dari tiga sheet, yaitu 2003, 2004, dan 2005. Isin rownya hanya header dan row yang pada kolom makanan sesuai dengan nama filenya.

Terima Kasih,

Akbar Jamaluddin Arsyad

__._,_.___

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

Messages in this topic (3)

Recent Activity:

• New Members 92

Visit Your Group

+-:: XL-mania ::::::::::::::::::::----------------------------------+
| tiap tanggal gajian, order buku "mengapa boss benci chart anda    |
| membludak :) ayo2 pesan yang belum punya....                      |
| 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              |
+-------------------------------------------------------------------+

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

.

__,_._,___