Option Explicit
Sub Сдвинуть()
CloseEmptyWb
ActiveSheet.Copy
Dim sh As Worksheet, arr As Variant
Set sh = ActiveSheet
arr = sh.Cells(1, 1).Resize(sh.UsedRange.Row + sh.UsedRange.Rows.Count - 1, sh.UsedRange.Column + sh.UsedRange.Columns.Count - 1).Value
Dim dic As Object: Set dic = CreateObject("Scripting.Dictionary")
Dim xa As Long, ya As Long, xb As Long
For ya = 1 To UBound(arr, 1)
For xa = 1 To UBound(arr, 2)
If arr(ya, xa) <> "" Then
If xa > dic(arr(ya, xa)) Then dic(arr(ya, xa)) = xa
End If
Next
Next
Dim Application_Calculation As XlCalculation: Application_Calculation = Application.Calculation: Application.Calculation = xlCalculationManual
Dim dicY As Object: Set dicY = CreateObject("Scripting.Dictionary")
Dim xMust As Long, rFind As Range, rAfter As Range, rMove As Range, startAddress As Long
For xa = 1 To UBound(arr, 2)
If arr(1, xa) <> "" Then
If dic.Exists(arr(1, xa)) Then
For xb = 1 To UBound(arr, 2)
For ya = 1 To UBound(arr, 1)
If arr(1, xa) = arr(ya, xb) Then
If dicY.Count = 0 Then
dicY(ya) = Empty
Else
If ya > dicY.keys()(dicY.Count - 1) Then
dicY(ya) = Empty
End If
End If
End If
Next
Next
End If
End If
Next
ya = sh.UsedRange.Row + sh.UsedRange.Rows.Count - 1
dicY(ya) = Empty
For ya = 1 To dicY.Count - 1
dicY(dicY.keys()(ya - 1)) = dicY.keys()(ya)
Next
Dim ys As Byte
For ys = 1 To 2
For xa = 1 To UBound(arr, 2)
If arr(1, xa) <> "" Then
If dic.Exists(arr(1, xa)) Then
xMust = dic(arr(1, xa))
Set rAfter = sh.Cells(1, 1)
startAddress = 0
Do
Set rFind = Nothing
On Error Resume Next
Set rFind = sh.UsedRange.Find(what:=arr(1, xa), After:=rAfter, LookAt:=xlWhole)
On Error GoTo 0
If rFind Is Nothing Then Exit Do
If startAddress = rFind.Row Then Exit Do
If startAddress = 0 Then startAddress = rFind.Row
Application.StatusBar = arr(1, xa) & " " & xa & " " & rFind.Row
If dicY.Exists(rFind.Row) Then
If xMust > rFind.Column Then
Set rMove = rFind.Resize(dicY(rFind.Row) - rFind.Row, xMust - rFind.Column)
rMove.Select
On Error Resume Next
rMove.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
If Err <> 0 Then sh.UsedRange.AutoFilter
On Error GoTo 0
ElseIf xMust < rFind.Column Then
Set rMove = rFind.Resize(dicY(rFind.Row) - rFind.Row, sh.UsedRange.Column + sh.UsedRange.Columns.Count - rFind.Column)
rMove.Select
sh.Cells(rMove.Row, xMust).Resize(rMove.Rows.Count, rMove.Columns.Count).Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
rMove.Cut
sh.Cells(rMove.Row, xMust).Select
ActiveSheet.Paste
Application.CutCopyMode = False
End If
End If
Set rAfter = rFind
DoEvents
Loop
End If
End If
Next
Next
Application.Calculation = Application_Calculation
End Sub
Private Sub CloseEmptyWb()
Dim wb As Workbook
For Each wb In Application.Workbooks
If wb.Path = "" Then wb.Close False
Next
End Sub
|
