Private Sub CommandButton1_Click()
Application.ScreenUpdating = False
Dim i, Z1 As Integer, blnFound As Boolean, xx As String
Dim list1 As New Collection
Set list1 = Nothing
y = Sheet1.Cells(Sheet1.Rows.Count, "A").End(xlUp).Row
On Error Resume Next
For i = 2 To y
xx = Range("A" & i)
If Len(xx) > 0 Then
list1.Add xx, CStr(xx)
End If
Next
With ThisWorkbook
For j = 1 To list1.Count
blnFound = False
For i = 1 To .Sheets.Count
If .Sheets(i).Name = list1.Item(j) Then
blnFound = True
Sheets(i).Move Before:=Sheets(j + 1)
End If
Next i
If blnFound = False Then
.Sheets.Add after:=Sheets(Sheets.Count)
With ActiveSheet
.Name = list1.Item(j)
End With
End If
Next j
End With
'===== sheets sort ==========='
With ThisWorkbook
For i = 2 To .Sheets.Count
For j = 1 To list1.Count
If .Sheets(i).Name = list1.Item(j) Then
Sheets(i).Move Before:=Sheets(j + 1)
End If
Next j
Next i
End With
'===== sheets sort ==========='
Application.ScreenUpdating = True
Sheet1.Select
End Sub
Private Sub CommandButton1_Click()
Application.ScreenUpdating = False
Dim i, Z1 As Integer, blnFound As Boolean, xx As String
Dim list1 As New Collection
Set list1 = Nothing
y = Sheet1.Cells(Sheet1.Rows.Count, "A").End(xlUp).Row
On Error Resume Next
For i = 2 To y
xx = Range("C" & i)
If Len(xx) > 0 Then
list1.Add xx, CStr(xx)
End If
Next
With ThisWorkbook
For J = 1 To list1.Count
blnFound = False
For i = 1 To .Sheets.Count
If .Sheets(i).Name = list1.Item(J) Then
blnFound = True
Sheets(i).Move Before:=Sheets(J + 1)
End If
Next i
If blnFound = False Then
.Sheets.Add after:=Sheets(Sheets.Count)
With ActiveSheet
.Name = list1.Item(J)
ActiveSheet.DisplayRightToLeft = True
End With
End If
Next J
End With
'===== sheets sort ==========='
With ThisWorkbook
For i = 1 To .Sheets.Count
For J = 1 To list1.Count
If .Sheets(i).Name = list1.Item(J) Then
blnFound = True
Sheets(i).Move Before:=Sheets(J + 1)
End If
Next J
Next i
End With
'===== sheets sort END ==========='
'==== DATA COPY TO SHEET ============='
Dim list2 As New Collection
y = Sheet1.Cells(Sheet1.Rows.Count, "A").End(xlUp).Row
For J = 2 To Sheets.Count
Set list2 = Nothing
For i = 2 To y
xx = Range("C" & i)
If xx = Sheets(J).Name Then
list2.Add Range("C" & i).Row
End If
Next
K = 2
YY = Sheets(J).Name
Range("A1:C1").Copy Destination:=Sheets(YY).Range("A1")
For i = 1 To list1.Count
Range("A" & list2.Item(i) & ":C" & list2.Item(i)).Copy Destination:=Sheets(YY).Range("A" & K)
K = K + 1
Next
Next
Sheet1.Select
Application.ScreenUpdating = True
End Sub
کامنت