@Gumay ... bisa gak proses d peringkat biar lgsg hasil sesuai dengan makro gabung1 ... Bagaimana klo hasil dr makro opennotepad2 d atas dan bawah hasil txt di tulis MAPtglhariini ...
Script berikut saya ambil sedikit dari diskusi di sini dengan tujuan agar tidak perlu mengulang-ulang proses inisialisasi objek FSO. Jadi script berikut bisa digabung dalam satu modul. Atau bisa juga dibuat terpisah. Scriptnya:
Option Explicit
Public m_xFSO As Object
Private Function InitFSO() As Boolean
On Error Resume Next
InitFSO = True
If m_xFSO Is Nothing Then
Set m_xFSO = CreateObject("Scripting.FileSystemObject")
If Err <> 0 Then InitFSO = False
End If
Err.Clear: On Error GoTo 0
End Function
Sub GabungData()
Dim sResult As String, sPath As String
Dim xlCell As Range, xlData As Range
Dim lRow As Long
On Error Resume Next
sPath = Sheet1.Range("M2")
If Right$(sPath, 1) <> "\" Then
sPath = sPath & "\"
End If
Set xlData = Sheet2.Range("A2:H6")
For Each xlCell In Sheet1.Range("A2:A10000")
sResult = vbNullString
If Len(xlCell) Then
With WorksheetFunction
lRow = .Match(xlCell, xlData.Columns(1), 0)
If Err = 0 Then
sResult = sResult & .Index(xlData, lRow, 3) & Chr$(32)
sResult = sResult & .Index(xlData, lRow, 4)
sResult = sPath & sResult & "\"
Sheet1.Cells(xlCell.Row, "H") = sResult
Else
Err.Clear
End If
End With
Else
Exit For
End If
Next
End Sub
Sub Simpan()
Dim sFileName As String
Dim xFile As Object
Dim xlCell As Range
Dim lCount As Long
On Error GoTo errHandler
sFileName = Sheet1.Range("M2")
If Right$(sFileName, 1) <> Chr$(92) Then sFileName = sFileName & Chr$(92)
sFileName = sFileName & Sheet1.Range("M3") & ".TXT"
Call InitFSO
With m_xFSO
'+-- Jika file tidak ada, maka buat file. Jika
'+-- file sudah ada, maka tambahkan data baru!
'+-- Jika ingin file hanya sebagai otuput saja
'+-- atau data akan ditimpa, maka gunakan mode
'+-- ForWriting.
Set xFile = .OpenTextFile(sFileName, ForAppending, True, False)
With xFile
lCount = 0
.WriteLine "MAP" & Format$(Now(), "yyyymmdd")
For Each xlCell In Sheet1.Range("A2:A10000")
If Len(xlCell) = 0 Then Exit For
.WriteLine xlCell
lCount = lCount + 1
Next
.WriteLine "MAP" & Format$(Now(), "yyyymmdd") & lCount
.Close
End With
End With
errHandler:
If Err Then
MsgBox "Proses gagal. Kesalahan #" & Err.Number & vbCrLf & _
Err.Description, vbCritical
End If
Err.Clear: On Error GoTo 0
End Sub
Demikian.