перенос чисел по ячейкам, проверка по всем листам книги

[alex241v]

здравствуйте есть проблема, с макросами я на вы .

1)есть 2 одинаковые строки допустим 4 и 5 , в столбце Н есть числа но они иногда дублируются, в столбце I тоже самое только там записаны слова. Есть макрос который удаляет повторяющуюся строку, но проблема в том что во второй повторяющейся строке в столбце R есть число которое нужно с 5 строки перекинуть на 4 и проделать это со всеми повторяющимися строками во всех листах книги .

2)есть вторая проблемка нужно сделать проверку по всем листам книги и также удалять повторяющиеся строки с переносом числа, листов там порядка 20-30 а у меня проверяет только по первому листу
помогите пожалуйста разобраться с этими проблемами , заранее большое спасибо )


вот макрос который удаляет одинаковые строки

Dim Start As Long, Finish As Long
Start = 2: col = 9
Application.ScreenUpdating = False
With ActiveSheet(.Rows.Count, col).End(xlUp).Row
Finish = .Cells(.Rows.Count, col).End(xlUp).Row
Set Rng = .Range(.Cells(Start, col), .Cells(Finish, col))
For i = Finish To Start Step -1
If Application.CountIf(Rng, Cells(i, col)) > 1 Then Rows(i).Delete
Next i
End With
Application.ScreenUpdating = True

[Aleksandr H.]

Сообщение от alex241v

1)есть 2 одинаковые строки допустим 4 и 5 , в столбце Н есть числа но они иногда дублируются в столбце I тоже самое только там записаны слова есть макрос который удаляет повторяющуюся строку но проблема в том что во второй повторяющейся строке в столбце R есть число которое нужно с 5 строки перекинуть на 4 и проделать это со всеми повторяющимися строками во всех листах книги .

Столько текста и только 1 запятая как понять что хочешь? Может хотяб файла примера выложишь ?

точно такая конструкция работает?

With ActiveSheet(.Rows.Count, col).End(xlUp).Row
.....
End With

[alex241v]

Сообщение от Aleksandr H.

Столько текста и только 1 запятая как понять что хочешь? Может хотяб файла примера выложишь ?

точно такая конструкция работает?

With ActiveSheet(.Rows.Count, col).End(xlUp).Row
.....
End With

прошу прощения, писал на скорую руку. Исправился

[alex241v]

Сообщение от Aleksandr H.

Столько текста и только 1 запятая как понять что хочешь? Может хотяб файла примера выложишь ?

точно такая конструкция работает?

With ActiveSheet(.Rows.Count, col).End(xlUp).Row
.....
End With

не работает

[alex241v]

к сожалению не могу файлом кинуть код ,а когда копирую то формат текста меняется

[alex241v]

это конечный кусок макроса
как видите почти ничего не понятно
'ïðè íàæàòèè êíîïêè ôàéëû íå èç ìýïïèíãà íå îòîáðàæàþòñÿ
If CheckBox2.Value = True Then

For Each wsheet In ActiveWorkbook.Worksheets

Sheets(wsheet.Name).Select

Start = 2: col = 8

With ActiveSheet
With ActiveSheet(.Rows.Count, col).End(xlUp).Row

Set Rng = .Range(.Cells(Start, col), .Cells(Finish, col))
For i = Finish To Start Step -1
If Application.CountIf(Rng, Cells(i, col)) < 1 Then Rows(i).Delete
Next i
End With

End With

Next wsheet
End If



If flac = 0 Then
'Ñîõðàíåíèå êíèãè ñ äàííûìè ÒÍÏ
ActiveWorkbook.SaveAs "Äàííûå ÒÍÏ íà " & Date & ".xlsx"
Else
ActiveWorkbook.SaveAs "Îáùàÿ.. ÒÍÏ íà " & Date & ".xlsx"
End If

Const sPath_in_Names = "Path4SaveCopyAs" ' èìÿ ýëåìåíòà êîëëåêöèè .Names, â êîòîðîì äîëæåí õðàíèòüñÿ ïóòü äëÿ ñîõðàíåíèÿ êîïèé ôàéëà
Dim sDirPath$, sExp$, sMainName$, FileName
With ActiveWorkbook
On Error Resume Next
sDirPath = .Names(sPath_in_Names).Value ' ñ÷èòàòü èç êîëëåêöèè .Names çíà÷åíèå, ðàíåå ñîõðàíåííîå ïîä èìåíåì sPath_in_Names
If Err Then .Names.Add sPath_in_Names, .Path & "\": sDirPath = .Path & "\" ' åñëè ñ÷èòàòü íå óäàëîñü, çíà÷èò ïóòü ðàíåå íå çàäàâàëñÿ è îí äëÿ ïåðâîãî ðàçà çàäà¸òñÿ ðàâíûì ActiveWorkbook.Path
sDirPath = Mid(sDirPath, 3, Len(sDirPath) - 3) ' óáðàòü èç ñ÷èòàííîãî çíà÷åíèÿ â íà÷àëå "= è â êîíöå "
sDirPath = sDirPath & IIf(Right(sDirPath, 1) = "\", "", "\") ' íà âñÿêèé ñëó÷àé (åñëè èìÿ áûëî çàäàíî â ðó÷íóþ è ïðè ýòîì íå âåðíî - áåç ñëýøà)
.Names(sPath_in_Names).Value = sDirPath ' çàïîìíèòü ïóòü ñîõðàíåíèÿ êîïèé â êîëëåêöèè .Names ïîä èìåíåì sPath_in_Names
sExp = Right(.Name, Len(.Name) - InStrRev(.Name, ".") + 1) ' ðàñøèðåíèå ôàéëà âìåñòå ñ òî÷êîé (íàïðèìåð, ".xls")
sMainName = Left(.Name, Len(.Name) - Len(sExp))
Do
FileName = sDirPath & sMainName & "(" & i & ")" & sExp: i = i + 1
Loop While Dir(FileName) <> "" ' ïîêà èìÿ íå áóäåò óíèêàëüíûì â ïàïêå
FileName = Application.GetSaveAsFilename(Initi alFileName:=FileName, _
FileFilter:="Excel Files (*" & sExp & "), *" & sExp & ", All Files (*.*),*.*", _
Title:="Ñîõðàíåíèå êîïèè ôàéëà") 'çàäàòü ïóòü ñîõðàíåíèÿ è èìÿ êîïèè ôàéëà â îêíå âûáîðà
If VarType(FileName) = vbBoolean Then Exit Sub ' åñëè íàæàëè "Îòìåíà", òî FileName = False, åñëè "Ñîõðàíèòü" - ïîëíûé ïóòü ê ôàéëó âìåñòå ñ åãî èìåíåì
sDirPath = Left(FileName, InStrRev(FileName, "\")) ' ïóòü ê ïàïêå ñîõðàíåíèÿ êîïèé áåç èìåíè ôàéëà
.Names(sPath_in_Names).Value = sDirPath ' çàïîìíèòü âûáðàííûé â äèàëîãå ïóòü â êîëëåêöèè .Names ïîä èìåíåì sPath_in_Names
.SaveCopyAs FileName
End With





ActiveWorkbook.Close 'çàêðûâàåì äàííóþ êíèãó
MsgBox "Âûïîëíåíî!"

' çàêðûâàåì âñå êíèãè, êðîìå òîé, èç êîòîðîé çàïóùåí ìàêðîñ. Çàêðûòèå áåç ñîõðàíåíèÿ
Dim wb As Workbook: Application.ScreenUpdating = False


For Each wb In Workbooks ' ïåðåáèðàåì âñå îòêðûòûå êíèãè
If Not wb Is ThisWorkbook Then
'If wb.Windows(1).Visible Then
wb.Close
'End If
End If
Next wb

Application.DisplayAlerts = False
Application.AskToUpdateLinks = False
'ActiveWorkbook.Close

' If Not appExl Is Nothing Then
' appExl.Quit
' Set appExl = Nothing
' End If

'End
Application.ScreenUpdating = Tru

[IgorGO]

в редакторе ВБА, перейдите на русскую раскладку, отметьте что нужно, копируйте, вставляйте сюда, Код заключите в тэги код #

[alex241v]

Private Sub CommandButton1_Click()

 Dim i As Integer
 Dim y As Variant
    Dim j As Integer
    Dim Add As Integer
    Dim col As Long
    Dim Rng As Object
    Dim txl As String
    Dim sbornik As Workbook
    Dim mapping As Workbook
    'Dim tnp As Workbook
    Dim AG As String
    Dim nb As String
    'Dim Filename As String
    Dim oFileSystemObject As Object
    Dim nfile As String
    Dim responce
    Dim shh As Worksheet
    Dim flac As Integer
    Dim sh As Worksheet
    'Dim appExl As Excel.Application

    
    Application.ScreenUpdating = False ' Отключаем “мерцание” окна
    
    'проверка указания пути к файлу сборника
    If TextBox1.Text = "" Then
        responce = MsgBox("Сборник ТПН не выбран. Пожалуйста, выберите сборник ТНП!", vbCritical)
        Exit Sub
    End If
    
    'проверка указания пути к файлу мэппингу
    If TextBox2.Text = "" Then
        responce = MsgBox("Файл с маппингом не выбран.Пожалуйста, выберите файл mapping_tnp.xlsx", vbCritical)
        Exit Sub
    End If
    
    If IsNull(ListBox1.List(0, 0)) Then
        responce = MsgBox("Выберете узлы для работы", vbCritical)
        Exit Sub
    End If
            
    'Отключаем появление запросов на обновление данных и системных запросов
    Application.DisplayAlerts = False
    Application.AskToUpdateLinks = False
        
    'открываем выбранный файл сборника Транснефтепродукта
    Set sbornik = Workbooks.Open(TextBox1.Text)
    sbornik.Windows(1).Visible = False 'отключаем видимость этого файла
    
    'открываем выбранный файл мэппинга
    Set mapping = Workbooks.Open(TextBox2.Text)
    mapping.Windows(1).Visible = False 'отключаем видимость этого файла
    
    'проверка правильности задания файла мэппинга, который для дальнейшей корректной работы должен называться mapping_tnp.xlsx
    If mapping.Name = "mapping_tnp.xlsx" Then
    Else
        MsgBox "Файл мэппинга должен называться mapping_tnp.xlsx"
        Exit Sub
    End If
    
    'задаем текущую директорию
    nb = ActiveWorkbook.Path
    
    'Filename = nb & "\" & "Данные ТНП для анализа от" & sbornik.Name & ".xlsx"
    'If Dir(Filename) <> "" Then
    '      Else
    '    MsgBox "Выгруженный файл #Данные ТНП для анализа...# уже содержится в этой директории. Удалите или переименуйте данный файл"
    'End If
    
    'получаем дату из титульного листа сборника (не работает на всех таблицах ввиду их разноформатности)
'    For i = 0 To ListBox1.ListCount - 1
'        txl = ListBox1.List(i, 0)
'        If txl = "Титул" Or txl = "титул" Or txl = "титул.л" Then
'            nfile = Mid(sbornik.Worksheets(txl).Cells(11, 1).Value, 13, 14)
'            Exit For
'        End If
'    Next
            
       
    'Создаем книгу для выгрузки данных по созданному шаблону и проверяем не открыта ли она в данный момент
    'если открыта, выводим информационное сообщение и заканчиваем программу
    Set oFileSystemObject = CreateObject("Scripting.FileSystemObject")
    If oFileSystemObject.FileExists(nb & "\" & "Данные ТНП на " & Date & ".xlsx") = False Or oFileSystemObject.FileExists(nb & "\" & "Общая. ТНП на " & Date & ".xlsx") = False Then
        With Workbooks.Add 'добавляем новую книгу в текущую директирию
            '.Worksheets.Add.Name = "Ваше имя"
            '.SaveAs "Данные ТНП для анализа" & ".xlsx"
            'MsgBox IIf(.Saved, "Книга сохранена успешно", "Ошибка при сохранении!")
            '.Close
           
        End With
    Else
        'Application.DisplayAlerts = True
        MsgBox "Файл с результатами по выгрузке данных ТНП уже открыт. Пожалуйста, закройте данный файл, и повторите действия."
        'Workbooks.Open (nb & "\" & "Данные ТНП для анализа" & ".xlsx")
        End
    End If
    
    
    'Set tnp = Workbooks.Open(nb & "\" & "Данные ТНП для анализа" & ".xlsx")
    'tnp.Windows(1).Visible = False
    
    'задаем имя сборника
    AG = sbornik.Name
    
    'ГЛАВНАЯ ЧАСТЬ - выполняем заполнение искомых таблиц
 
    
    If ListBox1.ListCount > 0 Then
        ActiveWorkbook.Worksheets.Add.Name = "Общая таблица" 'если в указанном сборнике присутствует хоть один лист, то создаем общую таблицу
        new_ws1 ("Общая таблица") 'создаем шапку
    End If
    
    flac = 0
    
    If CheckBox1.Value = True Then
        'проверка наличия необходимой вкладки в указанном файле
        flac = 1
'        For i = 0 To ListBox1.ListCount - 1
'            ListBox1.Selected(i) = True
'            ListBox1.Enabled = False
'        Next
    Else
        flac = 0
    End If

[alex241v]

    'пробегаем по всем пунктам в листбоксе, проверяем выбранны ли они и классифицируем на несколько групп
    For i = 0 To ListBox1.ListCount - 1
        If ListBox1.Selected(i) = True Then
            txl = ListBox1.List(i, 0)
            If txl = "МНПЗ" Or txl = "РНПК" Or txl = "ЯНОС" Or txl = "ТАИФ-НК" Or txl = "ТАНЕКО" Or txl = "ЛПДС Сызрань" Or txl = "ЛПДС Воскресенка" Or txl = "ЛПДС Черкассы" Or txl = "ЛПДС Салават" Or txl = "ПСП Андреевка" Or txl = "Антипинский НПЗ" Or txl = "ЛПДС Омск" Or txl = "ЛПДС Сокур" Then
                ActiveWorkbook.Worksheets.Add.Name = txl 'добавляем лист с таким же именем
                new_ws1 (txl) 'создаем шапку
                new_ws2_data (AG) 'заполняем таблицу данными
            ElseIf txl = "КНОС" Or txl = "КИНЕФ" Or txl = "НОРСИ" Or txl = "промежуточные" Then
                ActiveWorkbook.Worksheets.Add.Name = txl 'добавляем лист с таким же именем
                new_ws1 (txl) 'создаем шапку
                new_ws2_data (AG) 'заполняем таблицу данными
            ElseIf txl = "Казахстан" Then
                ActiveWorkbook.Worksheets.Add.Name = txl 'добавляем лист с таким же именем
                new_ws1 (txl) 'создаем шапку
                new_ws_data_kaz (AG) 'заполняем таблицу данными
            ElseIf txl = "ЧУП" Or txl = "УП ЗападТНП" Or txl = "ДП Прикарпат" Or txl = "Прикарпатзапад" Or txl = "ДП ПрикарпатЗапад" Then
                ActiveWorkbook.Worksheets.Add.Name = txl 'добавляем лист с таким же именем
                new_ws1 (txl) 'создаем шапку
                new_ws3_data (AG) 'заполняем таблицу данными
            ElseIf txl = "Автоналив РФ" Or txl = "авто(нов)" Or txl = "АВтоналив РФ" Then 'Or txl = "ж-д налив" Then 'Or txl = "ДП Прикарпат" Or txl = "Прикарпатзапад" Or txl = "ДП ПрикарпатЗапад" Then
                If flac = 0 Then
                    ActiveWorkbook.Worksheets.Add.Name = txl 'добавляем лист с таким же именем
                    new_ws1 (txl) 'создаем шапку
                    new_ws4_data (AG) 'заполняем таблицу данными
                End If
            ElseIf txl = "ж-д налив" Or txl = "налив жд (нов)" Or txl = "налив ЖД" Then
                If flac = 0 Then
                    ActiveWorkbook.Worksheets.Add.Name = txl 'добавляем лист с таким же именем
                    new_ws1 (txl) 'создаем шапку
                    new_ws5_data (AG) 'заполняем таблицу данными
                End If
            Else
'                If flac = 0 Then
'                    'обрабатываем оставшиеся пункты
'                    MsgBox "Вкладка «" & txl & "» носит информационный характер или ещё не реализована"
'                End If
            End If
        End If
    Next
 
     If CheckBox1.Value = True Then
        'проверка наличия необходимой вкладки в указанном файле
        'Application.DisplayAlerts = False
        For Each shh In Sheets
            If InStr(1, "Общая таблица", shh.Name, vbTextCompare) = 0 Then
                shh.Delete
            End If
        Next
        'Application.DisplayAlerts = True
    Else
        Sheets("Общая таблица").Delete
    End If
    


   'удаление повторяющейся строки (добавить перенос значения с нижней ячейки в верхнюю)
 Dim wsheet As Worksheet
Dim Start As Long, Finish As Long
For Each wsheet In ActiveWorkbook.Worksheets

Sheets(wsheet.Name).Select

Start = 2: col = 15

 With ActiveSheet
 Finish = .Cells(.Rows.Count, col).End(xlUp).Row
 Set Rng = .Range(.Cells(Start, col), .Cells(Finish, col))
 For i = Finish To Start Step -1
 If Application.CountIf(Rng, Cells(i, col)) > 1 Then Rows(i).Delete
 
 Next i
 End With



Next wsheet

    
  


 'при нажатии кнопки файлы не из мэппинга не отображаются
 If CheckBox2.Value = True Then

For Each wsheet In ActiveWorkbook.Worksheets

Sheets(wsheet.Name).Select

Start = 2: col = 8

 With ActiveSheet
 Finish = .Cells(.Rows.Count, col).End(xlUp).Row
 Set Rng = .Range(.Cells(Start, col), .Cells(Finish, col))
 For i = Finish To Start Step -1
 If Application.CountIf(Rng, Cells(i, col)) < 1 Then Rows(i).Delete
 Next i
 End With



Next wsheet
End If

[alex241v]

 
    If flac = 0 Then
        'Сохранение книги с данными ТНП
        ActiveWorkbook.SaveAs "Данные ТНП на " & Date & ".xlsx"
    Else
        ActiveWorkbook.SaveAs "Общая.. ТНП на " & Date & ".xlsx"
    End If
  
    Const sPath_in_Names = "Path4SaveCopyAs"   ' имя элемента коллекции .Names, в котором должен храниться путь для сохранения копий файла
    Dim sDirPath$, sExp$, sMainName$, FileName
    With ActiveWorkbook
    On Error Resume Next
    sDirPath = .Names(sPath_in_Names).Value   ' считать из коллекции .Names значение, ранее сохраненное под именем sPath_in_Names
    If Err Then .Names.Add sPath_in_Names, .Path & "\": sDirPath = .Path & "\"   ' если считать не удалось, значит путь ранее не задавался и он для первого раза задаётся равным ActiveWorkbook.Path
    sDirPath = Mid(sDirPath, 3, Len(sDirPath) - 3)   ' убрать из считанного значения в начале "= и в конце "
    sDirPath = sDirPath & IIf(Right(sDirPath, 1) = "\", "", "\")  ' на всякий случай (если имя было задано в ручную и при этом не верно - без слэша)
    .Names(sPath_in_Names).Value = sDirPath   ' запомнить путь сохранения копий в коллекции .Names под именем sPath_in_Names
    sExp = Right(.Name, Len(.Name) - InStrRev(.Name, ".") + 1)   ' расширение файла вместе с точкой (например, ".xls")
    sMainName = Left(.Name, Len(.Name) - Len(sExp))
    Do
        FileName = sDirPath & sMainName & "(" & i & ")" & sExp: i = i + 1
    Loop While Dir(FileName) <> ""   ' пока имя не будет уникальным в папке
    FileName = Application.GetSaveAsFilename(InitialFileName:=FileName, _
                    FileFilter:="Excel Files (*" & sExp & "), *" & sExp & ", All Files (*.*),*.*", _
                    Title:="Сохранение копии файла")   'задать путь сохранения и имя копии файла в окне выбора
    If VarType(FileName) = vbBoolean Then Exit Sub   ' если нажали "Отмена", то FileName = False, если "Сохранить" - полный путь к файлу вместе с его именем
    sDirPath = Left(FileName, InStrRev(FileName, "\"))   ' путь к папке сохранения копий без имени файла
    .Names(sPath_in_Names).Value = sDirPath   ' запомнить выбранный в диалоге путь в коллекции .Names под именем sPath_in_Names
    .SaveCopyAs FileName
    End With
    


  
    
    ActiveWorkbook.Close 'закрываем данную книгу
    MsgBox "Выполнено!"
    
     ' закрываем все книги, кроме той, из которой запущен макрос. Закрытие без сохранения
    Dim wb As Workbook: Application.ScreenUpdating = False
 

    For Each wb In Workbooks    ' перебираем все открытые книги
       If Not wb Is ThisWorkbook Then
            'If wb.Windows(1).Visible Then
                wb.Close
            'End If
       End If
    Next wb
    
    Application.DisplayAlerts = False
    Application.AskToUpdateLinks = False
    'ActiveWorkbook.Close
    
'    If Not appExl Is Nothing Then
'        appExl.Quit
'        Set appExl = Nothing
'    End If
   
    'End
  Application.ScreenUpdating = True
End Sub