Sub MengumpulkanDanMengextrakUniq()
' siti Vi // 24 Mei 20101
'------------------
Dim W As Worksheet
Dim dRng As Range, cel As Range, Hasil As Range
Dim Ar(), n As Long, Tx As String
Dim i As Integer, a As Integer, b As Integer, t As Variant
Set Hasil = Sheets("HASIL").Range("A2")
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Hasil.Parent.Activate
Hasil.CurrentRegion.ClearContents
Tx = "|"
For Each W In Worksheets
If Not LCase(W.Name) = "home" Then
If Not LCase(W.Name) = "hasil" Then
Set dRng = W.UsedRange
For Each cel In dRng
If Not cel = vbNullString Then
If InStr(1, Tx, "|" & cel & "|") = 0 Then
Tx = Tx & cel & "|"
n = n + 1
ReDim Preserve Ar(1 To n)
Ar(n) = CStr(cel.Text)
End If
End If
Next cel
End If
End If
Next W
n = UBound(Ar)
For i = 1 To n - 1
For b = n To (i + 1) Step -1
a = (b - 1)
If Ar(a) > Ar(b) Then t = Ar(b): Ar(b) = Ar(a): Ar(a) = t
Next b
Next i
For i = 1 To UBound(Ar)
Hasil(i, 1) = Ar(i)
Next i
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
2011/5/24 Andrie - <[email protected]>
>
>
> Mohon bantuannya bagaimana caranya buat macro copy data multisheet.
> File terlampir.
> Terima kasih
>
> __._,_
>
