I'm not sure if i have understood (my english is not good), but try:
Sub ListSheets()
Dim x As Integer
x = 100
Application.ScreenUpdating = False
For Each sh In Sheets
If sh.Name <> "Source" And sh.Name <> "Problem description" Then
Sheets("source").Range("AA" & x) = sh.Name
If Not IsError(Application.Match(sh.Name, Sheets("Source").Range("B:B"),
0)) Then
Sheets("source").Range("AB" & x) = Sheets("source").Range("H" &
Application.Match(sh.Name, Sheets("Source").Range("B:B"), 0)).Value
Else
Sheets("source").Range("AB" & x) = sh.[a1].Value
End If
x = x + 1
End If
Next
Sheets("Source").Activate
Sheets("Source").Range("AA100:AB" & 100 + Sheets.Count).Select
Sheets("Source").Sort.SortFields.Clear
Sheets("Source").Sort.SortFields.Add Key:=Range( _
"AB100:AB" & 100 + Sheets.Count), SortOn:=xlSortOnValues,
Order:=xlAscending, DataOption:= _
xlSortNormal
With ActiveWorkbook.Worksheets("Source").Sort
.SetRange Range("AA100:AB112")
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
i = 3
For j = 100 To 100 + Sheets.Count - 2
'For Each sh In Sheets
nm = Sheets("Source").Range("AA" & j)
If nm <> "" Then
Sheets(nm).Move Before:=Sheets(i)
i = i + 1
End If
Next
Sheets("Source").Range("AA100:AB" & 100 + Sheets.Count).Clear
Sheets("Source").Activate
Application.ScreenUpdating = True
End Sub
[Non-text portions of this message have been removed]
| Reply via web post | Reply to sender | Reply to group | Start a New Topic | Messages in this topic (4) |
Be sure to check out TechTrax Ezine for many, free Excel VBA articles! Go here: http://www.mousetrax.com/techtrax to enter the ezine, then search the ARCHIVES for EXCEL VBA.
----------------------------------
Visit our ExcelVBA group home page for more info and support files:
http://groups.yahoo.com/group/ExcelVBA
----------------------------------
More free tutorials and resources available at:
http://www.mousetrax.com
----------------------------------
Tidak ada komentar:
Posting Komentar