Kebetulan saya mendapat "wangsit" (bisikan ghoib entah dari dunia mana)
untuk ikut menanggapi case ini... walaupun mungkin hasilnya salah...
Sub MultiSheetDataToTabelTerpusat()
' siti Vi / 27 april 2011
' XL-mania case
'---------------------------------------------------
Dim FSO As Object
Dim FOL As Object
Dim F As Object
Dim dbTabel As Range
Dim sFolder As String
Dim CurrWB As Workbook
Dim r As Integer
Set dbTabel = ThisWorkbook.Sheets("DB").Cells(1).CurrentRegion
r = dbTabel.Rows.Count
sFolder = HomeSheet.Range("C3").Value
If Len(sFolder) = 0 Then
MsgBox "Folder belum ditentukan", 48, ThisWorkbook.Name
Exit Sub
End If
dbTabel.Parent.Activate
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
On Error GoTo Akhir
Set FSO = CreateObject("Scripting.FileSystemObject")
Set FOL = FSO.GetFolder(sFolder).Files
For Each F In FOL
If Not F.Name = ThisWorkbook.Name Then
Workbooks.Open Filename:=sFolder + "\" + F.Name
Set CurrWB = Workbooks(F.Name)
r = r + 1
With CurrWB.Sheets(1) ' <<-- hanya Sheet(index 1) yg diurusin
dbTabel(r, 1) = .Range("f4")
dbTabel(r, 2) = .Range("f5")
dbTabel(r, 3) = .Range("f6")
dbTabel(r, 4) = .Range("f7")
dbTabel(r, 5) = .Range("i4")
dbTabel(r, 6) = .Range("i5")
dbTabel(r, 7) = .Range("i6")
dbTabel(r, 8) = .Range("i7")
dbTabel(r, 10) = F.Name
End With
End If
If Not CurrWB Is Nothing Then CurrWB.Close
Set CurrWB = Nothing
Next F
dbTabel.Columns("A:J").Columns.AutoFit
Akhir:
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
End Sub
'------------------------------------
bagi member bersatatus dailydigest maupun webOnly jika berminat
dapat mengunduh lampiran workbook Guna WanFolderrrr(DataMerge).zip
On Tue, Apr 26, 2011 at 3:34 PM, Gunawan, Gunawan <Gunawan.Gunawan@sc.com> wrote:
Kebetulan saya mendapat pekerjaan untuk memindahkan data dari 1 file menjadi bentuk database di table lain…File pertama adalah file informasi pelanggan yang harus saya pindahkan menjadi bentuk database di file kedua.
Terdapat ratusan file 1 dimana satu file adalah file untuk satu pelanggan…
Saya ingin menggunakan macro untuk meng-copy file di file 1 ke file 2…
Data2 pada file 1 rencananya akan diletakkan di satu folder yang sama…
Mohon pencerahannya… J
Gunawan
__._,_.___
+-:: XL-mania ::::::::::::::::::::----------------------------------+
| wooHoooOoooo!!! "mengapa boss benci chart anda" mau dicetak lagi! |
| insanbiasa : "member 17,000++ yang beli buku mengapa boss benci |
| chart anda cuma segituhh? pokoknya� yang nggak beli: BANNED :D :D |
| 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 |
+-------------------------------------------------------------------+
| wooHoooOoooo!!! "mengapa boss benci chart anda" mau dicetak lagi! |
| insanbiasa : "member 17,000++ yang beli buku mengapa boss benci |
| chart anda cuma segituhh? pokoknya� yang nggak beli: BANNED :D :D |
| 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
.
__,_._,___
Nenhum comentário:
Postar um comentário