Выбрать дату в календареВыбрать дату в календаре

Страницы: 1
Не работает макрос сравнения двух списков в книге
 
Нет, точное.

Спасибо огромное! А можно, вопрос, почему моя логика не работает?
Изменено: vikttur - 05.07.2021 20:12:46
Не работает макрос сравнения двух списков в книге
 
Здравствуйте, вроде правильно написал макрос, но он мне заливает цветом все значения ячейки. По идее он должен был, заливать цветом, только те ячейки, которые не содержат схожих значений с листа 1 столбца В. Лист один содержит справочник по Ф.И.О., на втором листе надо залить цветом Ф.И.О., которые не содержатся в листе 1. В модуле два, последний макрос (Sub Inaz)
Изменено: vikttur - 05.07.2021 17:58:36
Объединить строки, при этом значения двух ячеек разнести из одного столбца на два
 
Здравствуйте уважаемые форумчане!
Столкнулся с проблемой, которую самостоятельно не могу решить. Буду рад любой помощи или совету.
В примере файл с данными, которые не могу сделать, чтоб через макрос трансформировались в нужной последовательности. Лист исходные данные представляет собой примерный вариант получаемых данных, кол-во строк может быть не ограниченным, а столбцов максимум всегда 10. Второй лист, примерный результат - это как бы хотелось получать эти данные.
В сети нашел следующий макрос, но он не до конца подходит. Буду рад любой помощи, заранее спасибо!
Код
Sub Trans()
Dim i As Long, J As Long, S As String, LastRow As Long, K As Integer
Dim TF As Boolean
Sheets("Лист2").Select
With Sheets("Лист1")
LastRow = .Cells(Rows.Count, 1).End(xlUp).Row
If LastRow > 2 Then .Rows("2:" & LastRow).Delete
LastRow = Cells(Rows.Count, 1).End(xlUp).Row
'будет преобразовываться вся страница расписание
J = 1
For i = 2 To LastRow
  J = J + 1: .Cells(J, 1) = Cells(i, 1)
  If Cells(i, 5) <> "" And Left(Cells(i, 5), 6) <> "Группа" Then ' есть Дисциплина 1
    For K = 2 To 5
      .Cells(J, K) = Cells(i, K) 'преподватель 1
    Next
    TF = Cells(i + 1, 5) & Cells(i + 1, 7) & Cells(i + 1, 9) <> ""
    If TF Then .Cells(J, 6) = Cells(i + 1, 5) ' есть Дисциплина 2
    If Cells(i, 7) <> "" Then '
      J = J + 1: .Cells(J, 1) = Cells(i, 1)
      .Cells(J, 5) = Cells(i, 7)     'преподаватель 2
      If TF Then .Cells(J, 6) = Cells(i + 1, 7) 'prepod
    End If
    If Cells(i, 9) <> "" Then 'есть Дисциплина 3
      J = J + 1: .Cells(J, 1) = Cells(i, 1)
      .Cells(J, 5) = Cells(i, 9) ' преподаватель 3
      If TF Then .Cells(J, 6) = Cells(i + 1, 9)
    End If
    If Cells(i, 11) <> "" Then 'есть Дисциплина 4
      J = J + 1: .Cells(J, 1) = Cells(i, 1)
      .Cells(J, 5) = Cells(i, 11) ' преподаватель 4
      If TF Then .Cells(J, 6) = Cells(i + 1, 11)
End If
    If TF Then i = i + 1
  End If
Next
End With
End Sub
Как оставить группировку строк в гугл таблицах?
 
Здравствуйте

Есть макрос в эксель, который позволяет при защите листа оставить работу с группировкой строк, пытался написать скрипт для гугл таблиц не получилось

в свое время на просторах интернета нашел макрос для экселя, который позволяет работать с группировкой строк при защищенном листе, сейчас в связи с переходом образования в дистант пытаюсь сделать тоже самое в гугл таблицах. Возник вопрос, что просто взять и перенести макрос не получается, попытался написать java script, но так как являюсь гуманитарием, видимо делаю сто процентов что-то не так. Прошу помощи, если кто может помочь с переносом или подсказать как это надо делать правильно. Буду рад любой помощи и заранее ОГРОМНОЕ СПАСИБО (в случае чего могу шоколадками).
1) Пример макроса эксель:
Код
Private Sub Workbook_Open()     
Sheets("Нагрузка").EnableOutlining = True   
Sheets("Нагрузка").Protect DrawingObjects:=True, Contents:=True, Scenarios:=True _         , 
AllowInsertingColumns:=True, AllowInsertingRows:=True, AllowFiltering:=True, UserInterfaceOnly:=True, Password:="1234" 
End Sub  

2) Jaca Script, который попытался написать основываясь на информации гугла

Код
function myFuction ()
{var sheet = SpreadsheetApp . getActiveSheet (); 
var protection = sheet.protect ().setDescription ( "Лист1" ); 
var unprotected = sheet. getRange ( 'Лист1!F5: Лист1!J1000' ); 
var sheet.
 protection.setUnprotectedRanges([unprotected]);}
Обратный ход макроса, Возможность работы макроса в обратную сторону при изменение исходных данных
 
Да формат есть, .plx это формат "Шахт"
Обратный ход макроса, Возможность работы макроса в обратную сторону при изменение исходных данных
 
Здравствуйте, дорогие участники форума.
Есть один такой вопрос, очень сложный. Есть корпоративная программа("Шахты"), которая выгружает файл в эксель формате при помощи макроса. Есть ли возможность сделать работу макроса в обратной форме, чтоб при изменение исходных файлов в эксель их трансформировать в нужный формат. Спасибо заранее, за ответы и помощь.
Исходный макрос выглядит вот так:
Код
ub MainMacro()
      On Error Resume Next
    ThisWorkbook.Sheets(1).Name = "Start"
    For i = ThisWorkbook.Sheets.Count To 1 Step -1
        If ThisWorkbook.Sheets(i).Name <> "Start" Then
            ThisWorkbook.Sheets(i).Delete
        End If
    Next
    
    CopyNote
    CopyKaf
    CopyDiag
    CopyVex
    CopyGEK
    CopyGAK
    CopyKP
    CopyPractices
    CopyCourses
    CopyPivotTable
    CopyCmptDistr
    CopyCmptList
    CopySpecAsp
    CopyReduce
    CopyPlan
    CopyPlanSvod
    CopyGYP
    CopyTitle
    
    For i = ThisWorkbook.Sheets.Count To 1 Step -1
        With ThisWorkbook.Sheets(i)
            .Select
            .PageSetup.LeftMargin = Application.InchesToPoints(0.393700787401575)
            .PageSetup.RightMargin = Application.InchesToPoints(0.393700787401575)
            .PageSetup.TopMargin = Application.InchesToPoints(0.393700787401575)
            .PageSetup.BottomMargin = Application.InchesToPoints(0.393700787401575)
            .PageSetup.HeaderMargin = Application.InchesToPoints(0)
            .PageSetup.FooterMargin = Application.InchesToPoints(0)
            .PageSetup.Orientation = xlLandscape
            Cells.Select
            Selection.NumberFormat = "@"
            .Range("A1").Select
        End With
    Next
    
    ActiveWindow.TabRatio = 0.75
    Sheets("Start").Visible = False
    Sheets("Титул").Select
End Sub
Sub CopyDiag()
    Application.ScreenUpdating = False
    openxlsa = ThisWorkbook.Path & "\Sheets\sheetDiag.xls"
    If Dir(openxlsa) = "" Then
        Exit Sub
    End If
    Set xlsA = Workbooks.Open(Filename:=openxlsa, ReadOnly:=True)
      
    xlsA.Sheets(1).Copy Before:=ThisWorkbook.Sheets(1)
    
    With ThisWorkbook.Sheets(1)
        .Select
        .Name = "Диаграмма курсов"
         ActiveWindow.DisplayGridlines = False
        Application.ScreenUpdating = False
    End With
    
    xlsA.Close
    Application.ScreenUpdating = True
End Sub
Sub CopyVex()
    Application.ScreenUpdating = False
    openxlsa = ThisWorkbook.Path & "\Sheets\sheetVex.xls"
    If Dir(openxlsa) = "" Then
        Exit Sub
    End If
    Set xlsA = Workbooks.Open(Filename:=openxlsa, ReadOnly:=True)
      
    xlsA.Sheets(1).Copy Before:=ThisWorkbook.Sheets(1)
    
    With ThisWorkbook.Sheets(1)
        .Select
        .Name = "Выпускные экзамены"
         ActiveWindow.DisplayGridlines = False
        Application.ScreenUpdating = False
    End With
    
    xlsA.Close
    Application.ScreenUpdating = True
End Sub
Sub CopyGAK()
    Application.ScreenUpdating = False
    openxlsa = ThisWorkbook.Path & "\Sheets\sheetGAK.xls"
    If Dir(openxlsa) = "" Then
        Exit Sub
    End If
    Set xlsA = Workbooks.Open(Filename:=openxlsa, ReadOnly:=True)
      
    xlsA.Sheets(1).Copy Before:=ThisWorkbook.Sheets(1)
    
    With ThisWorkbook.Sheets(1)
        .Select
        .Name = "ГЭК (ВКР)"
         ActiveWindow.DisplayGridlines = False
        Application.ScreenUpdating = False
    End With
    
    xlsA.Close
    Application.ScreenUpdating = True
End Sub
Sub CopyKP()
    Application.ScreenUpdating = False
    openxlsa = ThisWorkbook.Path & "\Sheets\sheetKP.xls"
    If Dir(openxlsa) = "" Then
        Exit Sub
    End If
    Set xlsA = Workbooks.Open(Filename:=openxlsa, ReadOnly:=True)
      
    xlsA.Sheets(1).Copy Before:=ThisWorkbook.Sheets(1)
    
    With ThisWorkbook.Sheets(1)
        .Select
        .Name = "Курсовые"
         ActiveWindow.DisplayGridlines = False
        Application.ScreenUpdating = False
    End With
    
    xlsA.Close
    Application.ScreenUpdating = True
End Sub
Sub CopyGEK()
    Application.ScreenUpdating = False
    openxlsa = ThisWorkbook.Path & "\Sheets\sheetGEK.xls"
    If Dir(openxlsa) = "" Then
        Exit Sub
    End If
    Set xlsA = Workbooks.Open(Filename:=openxlsa, ReadOnly:=True)
      
    xlsA.Sheets(1).Copy Before:=ThisWorkbook.Sheets(1)
    
    With ThisWorkbook.Sheets(1)
        .Select
        .Name = "ГЭК"
         ActiveWindow.DisplayGridlines = False
        Application.ScreenUpdating = False
    End With
    
    xlsA.Close
    Application.ScreenUpdating = True
End Sub
Sub CopyPractices()
    Application.ScreenUpdating = False
    openxlsa = ThisWorkbook.Path & "\Sheets\sheetPractices.xls"
    If Dir(openxlsa) = "" Then
        Exit Sub
    End If
    Set xlsA = Workbooks.Open(Filename:=openxlsa, ReadOnly:=True)
      
    xlsA.Sheets(1).Copy Before:=ThisWorkbook.Sheets(1)
    
    With ThisWorkbook.Sheets(1)
        .Select
        .Name = "Практики"
         ActiveWindow.DisplayGridlines = False
        Application.ScreenUpdating = False
    End With
    
    xlsA.Close
    Application.ScreenUpdating = True
End Sub
Sub CopyNote()
    'On Error Resume Next
    Application.ScreenUpdating = False
    
    openxlsa = ThisWorkbook.Path & "\Sheets\sheetNote.xls"
    If Dir(openxlsa) = "" Then
        Exit Sub
    End If
    Set xlsA = Workbooks.Open(Filename:=openxlsa, ReadOnly:=True)
      
    xlsA.Sheets(1).Copy Before:=ThisWorkbook.Sheets(1)
    
    With xlsA.Sheets(1) 'здесь путь, откуда копировать
    .[A1:H100].Copy [a1] 'а1 - это куда копировать
    '.Parent.Close SaveChanges:=False ' или True, закрываем источник
    End With
     
    With ThisWorkbook.Sheets(1)
        .Select
        .Name = "Примечание"
         ActiveWindow.DisplayGridlines = False
         '.Rows(1).RowHeight = 15
        '.Columns(1).ColumnWidth = 2.5
        
'        .Cells(1, 2).Value = "Пояснения"
'        .Cells(1, 2).Font.Name = "Tahoma"
'        .Cells(1, 2).Font.Bold = True
'        .Cells(1, 2).Font.Size = 9
'        .Range(.Cells(1, 2), .Cells(1, 4)).Interior.ColorIndex = 2
'        .Range(.Cells(1, 2), .Cells(1, 4)).Merge
        
        '.Range(.Cells(1, 1), .Cells(101, 1)).Interior.ColorIndex = 2
        Application.ScreenUpdating = False
        'AutoFitMergedCellRowHeight [a1:h200]
    End With
    
    xlsA.Close
    Application.ScreenUpdating = True
End Sub
Sub CopyKaf()
    Application.ScreenUpdating = False
    openxlsa = ThisWorkbook.Path & "\Sheets\sheetKaf.xls"
    If Dir(openxlsa) = "" Then
        Exit Sub
    End If
    Set xlsA = Workbooks.Open(Filename:=openxlsa, ReadOnly:=True)
      
    xlsA.Sheets(1).Copy Before:=ThisWorkbook.Sheets(1)
    
    With ThisWorkbook.Sheets(1)
        .Select
        .Name = "Кафедры"
         ActiveWindow.DisplayGridlines = False
        Application.ScreenUpdating = False
    End With
    
    xlsA.Close
    Application.ScreenUpdating = True
End Sub
Sub CopySpecAsp()
    Application.ScreenUpdating = False
    openxlsa = ThisWorkbook.Path & "\Sheets\sheetSpec.xls"
    If Dir(openxlsa) = "" Then
        Exit Sub
    End If
    Set xlsA = Workbooks.Open(Filename:=openxlsa, ReadOnly:=True)
      
    xlsA.Sheets(1).Copy Before:=ThisWorkbook.Sheets(1)
    
    With ThisWorkbook.Sheets(1)
        .Select
        .Name = "Спец"
         ActiveWindow.DisplayGridlines = False
        Application.ScreenUpdating = False
    End With
    
    xlsA.Close
    Application.ScreenUpdating = True
End Sub
Sub CopyTitle()
    Application.ScreenUpdating = False
    
    openxlsa = ThisWorkbook.Path & "\Sheets\sheetTitle.xls"
    If Dir(openxlsa) = "" Then
        Exit Sub
    End If
    Set xlsA = Workbooks.Open(Filename:=openxlsa, ReadOnly:=True)
      
    xlsA.Sheets(1).Copy Before:=ThisWorkbook.Sheets(1)
    
    With ThisWorkbook.Sheets(1)
        .Select
        .PageSetup.Zoom = False
        .PageSetup.FitToPagesWide = 1
        .PageSetup.FitToPagesTall = False
        .Name = "Титул"
        ActiveWindow.DisplayGridlines = False
        .Columns("A:A").Select
        Selection.Delete Shift:=xlToLeft
        .Rows("1:1").Select
        Selection.Delete Shift:=xlUp
        .Cells(1, 1).Select
        For r = 1 To 255
            For cl = 1 To 255
                If .Cells(r, cl).Interior.ColorIndex = 20 Then
                    .Cells(r, cl).Interior.ColorIndex = 35
                 End If
            Next cl
        Next r
    End With
    
    xlsA.Close
    Application.ScreenUpdating = True
End Sub

Sub CopyGYP()
    Application.ScreenUpdating = False
    
    openxlsa = ThisWorkbook.Path & "\Sheets\sheetGYP.xls"
    If Dir(openxlsa) = "" Then
        Exit Sub
    End If
    Set xlsA = Workbooks.Open(Filename:=openxlsa, ReadOnly:=True)
      
    xlsA.Sheets(1).Copy Before:=ThisWorkbook.Sheets(1)
    
    With ThisWorkbook.Sheets(1)
        .Select
        .PageSetup.Zoom = False
        .PageSetup.FitToPagesWide = 1
        .PageSetup.FitToPagesTall = False
        .Name = "График"
        ActiveWindow.DisplayGridlines = False
        Columns("A:A").Select
        Selection.Delete Shift:=xlToLeft
        Dim r As Integer
        Dim cl As Integer
        Dim bot As Integer
        Dim rght As Integer
        Dim e As Integer
        e = 53
        'вертикальный текст в шапке
        For r = 2 To 3
            For cl = 2 To e
                If .Cells(r, cl).Value Like "*-*" Then
                    .Cells(r, cl).Orientation = 90
                 End If
            Next cl
        Next r
        
        For r = 256 To 1 Step -1
            If .Cells(r, 1).Value <> "" Then
                bot = r
                Exit For
            End If
        Next r
        For r = 1 To bot
            If .Cells(r, 1).Value Like "*Сводные данные*" Then
                rsvod = r
                Exit For
            End If
        Next r
        For cl = 256 To 1 Step -1
            If .Cells(rsvod + 1, cl).Value <> "" Or .Cells(rsvod + 2, cl).Value <> "" Then
                rght = cl
                Exit For
            End If
        Next cl
        For r = 1 To bot
            If .Cells(r, 1).Value Like "*График сессий*" Then
                e = 72
                Exit For
            End If
'            If .Cells(r, 1).Value = " Студентов" Or .Cells(r, 1).Value = " Групп" Then
'                For cl = 2 To rght
'                    If Mid(.Cells(rsvod + 1, cl).Value, 1, 4) = "Курс" Then
'                        .Cells(r, cl).Interior.ColorIndex = 35
'                    Else
'                        .Cells(r, cl).Interior.ColorIndex = 2
'                    End If
'                Next cl
'            End If
        Next r
        .Range(.Cells(rsvod + 1, 1), .Cells(bot, rght)).Font.Size = 10
        Dim ln As Integer
        ln = 0
        If rght < e Then
            rght = e
        End If
        For r = 1 To bot
            For cl = 1 To rght
                If Mid(.Cells(r, cl).Value, 1, 3) = "tdp" Then
                    With .Cells(r, cl).Interior
                        .Pattern = xlLightUp
                        .PatternColorIndex = 13
                        .TintAndShade = 0
                        .PatternTintAndShade = 0
                    End With
                End If
                ln = Len(.Cells(r, cl).Value)
                If ln > 0 Then
                    If Mid(.Cells(r, cl).Value, ln, 1) = "#" Then
                        .Cells(r, cl).Value = Replace(.Cells(r, cl).Value, "#", "")
                        .Cells(r, cl).Value = Replace(.Cells(r, cl).Value, ".", "")
                        '.Cells(r, cl).Font.ColorIndex = 16
                        With .Cells(r, cl).Interior
                            .Pattern = xlGray50
                            .PatternColorIndex = 16
                            .TintAndShade = 0
                            .PatternTintAndShade = 0
                        End With
                    ElseIf Mid(.Cells(r, cl).Value, ln, 1) = "." Then
                        .Cells(r, cl).Value = Replace(.Cells(r, cl).Value, ".", "")
                        With .Cells(r, cl).Interior
                            '.Pattern = xlSolid
                            '.Pattern = xlGray16
                            '.PatternColorIndex = xlAutomatic
                            .Color = 10079487
                            '.TintAndShade = 0
                            '.PatternTintAndShade = 0
                        End With
                    End If
                End If
                
'                    Range("B13:Z18").Select
'    With Selection.Font
'        .Name = "Tahoma"
'        .FontStyle = "обычный"
'        .Size = 8
'        .Strikethrough = False
'        .Superscript = False
'        .Subscript = False
'        .OutlineFont = False
'        .Shadow = False
'        .Underline = xlUnderlineStyleNone
'        .ThemeColor = xlThemeColorLight1
'        .TintAndShade = 0.349986267
'        .ThemeFont = xlThemeFontNone
'    End With
'    With Selection.Interior
'        .Pattern = xlGray50
'        .PatternThemeColor = xlThemeColorLight1
'        .ColorIndex = 2
'        .TintAndShade = 0
'        .PatternTintAndShade = 0.499984740745262
'    End With
'    Range("AC13:AC18").Select
                
                If Mid(.Cells(r, cl).Value, 1, 3) = "tdp" Then
                    .Cells(r, cl).Value = ""
                End If
            Next cl
        Next r
        
        .Cells(2, 2).Select
    End With
    
    xlsA.Close
    
    Application.ScreenUpdating = True
End Sub

Sub CopyPlan()
    Application.ScreenUpdating = False
    openxlsa = ThisWorkbook.Path & "\Sheets\sheetPlan.xls"
    If Dir(openxlsa) = "" Then
        Exit Sub
    End If
    Set xlsA = Workbooks.Open(Filename:=openxlsa, ReadOnly:=True)
      
    xlsA.Sheets(1).Copy Before:=ThisWorkbook.Sheets(1)
    
    With ThisWorkbook.Sheets(1)
        .Name = "План"
        For i = 6 To 1250
          If .Cells(i, 2).Value <> "" Then .Rows(i).EntireRow.AutoFit
          If .Cells(i, 1).Value = "white" Then .Cells(i, 1).Value = ""
          If .Cells(i, 1).Value = "invalid" Then .Cells(i, 1).Value = "Адаптац."
        Next
    End With
    
    'xlsA.Close
    

    
            On Error Resume Next
            xlsA.Close
    Application.ScreenUpdating = True
End Sub

Sub CopyPlanSvod()
    Application.ScreenUpdating = False
    
    openxlsa = ThisWorkbook.Path & "\Sheets\sheetSPlan.xls"
    If Dir(openxlsa) = "" Then
        Exit Sub
    End If
    Set xlsA = Workbooks.Open(Filename:=openxlsa, ReadOnly:=True)
      
    xlsA.Sheets(1).Copy Before:=ThisWorkbook.Sheets(1)
  
    With ThisWorkbook.Sheets(1)
        .Name = "ПланСвод"
        
        For i = 6 To 1250
          If .Cells(i, 2).Value <> "" Then .Rows(i).EntireRow.AutoFit
          If .Cells(i, 1).Value = "white" Then .Cells(i, 1).Value = ""
          If .Cells(i, 1).Value = "invalid" Then .Cells(i, 1).Value = "Адаптац."
        Next
    End With
            On Error Resume Next
            xlsA.Close
    Application.ScreenUpdating = True
End Sub

Sub CopyCmptList()
    Application.ScreenUpdating = False
    
    openxlsa = ThisWorkbook.Path & "\Sheets\sheetCmptList.xls"
    If Dir(openxlsa) = "" Then
        Exit Sub
    End If
    Set xlsA = Workbooks.Open(Filename:=openxlsa, ReadOnly:=True)
      
    xlsA.Sheets(1).Copy Before:=ThisWorkbook.Sheets(1)
    
    With ThisWorkbook.Sheets(1)
        .Select
        .Name = "Компетенции"
        ActiveWindow.DisplayGridlines = False
           
    End With
    
    xlsA.Close
    Application.ScreenUpdating = True
End Sub

Sub CopyCmptDistr()
    Application.ScreenUpdating = False
    openxlsa = ThisWorkbook.Path & "\Sheets\sheetCmptDD.xls"
    If Dir(openxlsa) = "" Then
        Exit Sub
    End If
    Set xlsA = Workbooks.Open(Filename:=openxlsa, ReadOnly:=True)
      
    xlsA.Sheets(1).Copy Before:=ThisWorkbook.Sheets(1)
    
    With ThisWorkbook.Sheets(1)
        .Select
        .Name = "Компетенции(2)"
    End With
    xlsA.Close
    Application.ScreenUpdating = True
End Sub

Sub CopyCoursesNew()
    Application.ScreenUpdating = False
    Dim iC As Byte
    
    For i = 1 To 7
        iC = 8 - i
          'On Error Resume Next
        openxlsa = ThisWorkbook.Path & "\Sheets\sheetCourse" & iC & ".xls"
        If Dir(openxlsa) <> "" Then
            Set xlsA = Workbooks.Open(Filename:=openxlsa, ReadOnly:=True)
            xlsA.Sheets(1).Copy Before:=ThisWorkbook.Sheets(1)
    
            With ThisWorkbook.Sheets(1)
                .Select
                .Name = "Курс" & iC
                ActiveWindow.DisplayGridlines = False
                ActiveWindow.Zoom = 85
                    For cl = 1 To 21
                        .Columns(1).Delete
                    Next cl
                .Rows(7).EntireRow.Hidden = False
                With .Range(.Cells(8, 22), .Cells(12, 25))
                    .Interior.ColorIndex = xlNone
                    .Borders(xlDiagonalDown).LineStyle = xlNone
                    .Borders(xlDiagonalUp).LineStyle = xlNone
                    .Borders(xlEdgeLeft).LineStyle = xlNone
                    With .Borders(xlEdgeTop)
                        .LineStyle = xlContinuous
                        .Weight = xlThin
                        .ColorIndex = xlAutomatic
                    End With
                    With .Borders(xlEdgeBottom)
                        .LineStyle = xlContinuous
                        .Weight = xlMedium
                        .ColorIndex = xlAutomatic
                    End With
                    .Borders(xlEdgeLeft).LineStyle = xlNone
                    With .Borders(xlEdgeRight)
                        .LineStyle = xlContinuous
                        .Weight = xlThin
                        .ColorIndex = xlAutomatic
                    End With
                    .Borders(xlInsideVertical).LineStyle = xlNone
                    .Borders(xlInsideHorizontal).LineStyle = xlNone
                End With
                For rw = 1000 To 15 Step -1
                    If .Rows(rw).EntireRow.Hidden Then
                        .Rows(rw).Delete
                    End If
                Next rw
                .Range("V8:Y8").Select
                ActiveWindow.FreezePanes = True
            End With
            xlsA.Close
        End If
    Next i
    Application.ScreenUpdating = True
End Sub
Sub CopyReduce()
    Application.ScreenUpdating = False
    Dim lastc As Integer
    Dim lastr As Integer
    
    'On Error Resume Next
    openxlsa = ThisWorkbook.Path & "\Sheets\sheetReduce.xls"
    If Dir(openxlsa) = "" Then
        Exit Sub
    End If
    Set xlsA = Workbooks.Open(Filename:=openxlsa, ReadOnly:=True)
    xlsA.Sheets(1).Copy Before:=ThisWorkbook.Sheets(1)
    With ThisWorkbook.Sheets(1)
        .Select
        .Name = "Переаттестовано"
        lastc = 0
        lastr = 0
        
        For x = 50 To 1 Step -1
            If .Cells(3, x).Value <> "" Then
            lastc = x
            Exit For
            End If
        Next x
        
        For y = 150 To 1 Step -1
            If .Cells(y, 13).Value <> "" Then
            lastr = y
            Exit For
            End If
        Next y
        
        With .Range(.Cells(1, 1), .Cells(lastr, lastc))
            'Range(Cells(1, 1), Cells(138, 29)).Select
            .Interior.ColorIndex = xlNone
            .Borders(xlDiagonalDown).LineStyle = xlNone
            .Borders(xlDiagonalUp).LineStyle = xlNone
            With .Borders(xlEdgeLeft)
                .LineStyle = xlContinuous
                .Weight = xlThin
                .ColorIndex = xlAutomatic
            End With
            With .Borders(xlEdgeTop)
                .LineStyle = xlContinuous
                .Weight = xlThin
                .ColorIndex = xlAutomatic
            End With
            With .Borders(xlEdgeBottom)
                .LineStyle = xlContinuous
                .Weight = xlThin
                .ColorIndex = xlAutomatic
            End With
            With .Borders(xlEdgeRight)
                .LineStyle = xlContinuous
                .Weight = xlThin
                .ColorIndex = xlAutomatic
            End With
            With .Borders(xlInsideVertical)
                .LineStyle = xlContinuous
                .Weight = xlThin
                .ColorIndex = xlAutomatic
            End With
            With .Borders(xlInsideHorizontal)
                .LineStyle = xlContinuous
                .Weight = xlThin
                .ColorIndex = xlAutomatic
            End With
        End With
    End With
    xlsA.Close
    Application.ScreenUpdating = True
End Sub
Sub CopyCourses()
    Application.ScreenUpdating = False
    Dim iC As Byte
    Dim lastc As Integer
    Dim lastr As Integer
                
    For i = 1 To 7
        iC = 8 - i
          'On Error Resume Next
        openxlsa = ThisWorkbook.Path & "\Sheets\sheetCourse" & iC & ".xls"
        If Dir(openxlsa) <> "" Then
            Set xlsA = Workbooks.Open(Filename:=openxlsa, ReadOnly:=True)
            xlsA.Sheets(1).Copy Before:=ThisWorkbook.Sheets(1)
            With ThisWorkbook.Sheets(1)
                .Select
                .Name = "Курс" & iC
                lastc = 0
                lastr = 0
                
                For x = 30 To 1 Step -1
                    If .Cells(3, x).Value <> "" Then
                    lastc = x
                    Exit For
                    End If
                Next x
                
                For y = 150 To 1 Step -1
                    If .Cells(y, 13).Value <> "" Then
                    lastr = y
                    Exit For
                    End If
                Next y
                
                With .Range(.Cells(1, 1), .Cells(lastr, lastc))
                    'Range(Cells(1, 1), Cells(138, 29)).Select
                    .NumberFormat = "@"
                    .Interior.ColorIndex = xlNone
                    .Borders(xlDiagonalDown).LineStyle = xlNone
                    .Borders(xlDiagonalUp).LineStyle = xlNone
                    With .Borders(xlEdgeLeft)
                        .LineStyle = xlContinuous
                        .Weight = xlThin
                        .ColorIndex = xlAutomatic
                    End With
                    With .Borders(xlEdgeTop)
                        .LineStyle = xlContinuous
                        .Weight = xlThin
                        .ColorIndex = xlAutomatic
                    End With
                    With .Borders(xlEdgeBottom)
                        .LineStyle = xlContinuous
                        .Weight = xlThin
                        .ColorIndex = xlAutomatic
                    End With
                    With .Borders(xlEdgeRight)
                        .LineStyle = xlContinuous
                        .Weight = xlThin
                        .ColorIndex = xlAutomatic
                    End With
                    With .Borders(xlInsideVertical)
                        .LineStyle = xlContinuous
                        .Weight = xlThin
                        .ColorIndex = xlAutomatic
                    End With
                    With .Borders(xlInsideHorizontal)
                        .LineStyle = xlContinuous
                        .Weight = xlThin
                        .ColorIndex = xlAutomatic
                    End With
                End With
            End With
            xlsA.Close
        End If
    Next i
    Application.ScreenUpdating = True
End Sub

Sub CopyPivotTable()
    Application.ScreenUpdating = False
    
    openxlsa = ThisWorkbook.Path & "\Sheets\sheetPivotTable.xls"
    If Dir(openxlsa) = "" Then
        Exit Sub
    End If
    Set xlsA = Workbooks.Open(Filename:=openxlsa, ReadOnly:=True)
      
    xlsA.Sheets(1).Copy Before:=ThisWorkbook.Sheets(1)
    
    With ThisWorkbook.Sheets(1)
        .Select
        .Name = "Свод"
        ActiveWindow.DisplayGridlines = False
            For r = 1 To 30
                If .Cells(r, 2).Value > "" Then
                    Call RangeBordersOutside(.Range(.Cells(r, 1), .Cells(r, 2)), xlThin)
                    Call RangeBordersInside(.Range(.Cells(r, 1), .Cells(r, 2)), xlThin)
                    If InStr(1, .Cells(r, 1).Value, ".") > 0 Then
                        .Range(.Cells(r, 1), .Cells(r, 2)).Interior.ColorIndex = 34
                        .Cells(r, 10).Interior.ColorIndex = 34
                        For cl = 13 To 255
                            If .Cells(2, cl).Value = "Всего" Then
                                .Cells(r, cl).Interior.ColorIndex = 34
                            End If
                        Next
                    End If
                End If
            Next r
    End With
    
    xlsA.Close
    Application.ScreenUpdating = True
End Sub

Private Sub RangeBordersOutside(Rng As Range, xlW As Long)
    With Rng
        With .Borders(xlTop)
            .LineStyle = xlContinuous
            .Weight = xlW
            .ColorIndex = xlAutomatic
        End With
        With .Borders(xlBottom)
            .LineStyle = xlContinuous
            .Weight = xlW
            .ColorIndex = xlAutomatic
        End With
        With .Borders(xlLeft)
            .LineStyle = xlContinuous
            .Weight = xlW
            .ColorIndex = xlAutomatic
        End With
        With .Borders(xlRight)
            .LineStyle = xlContinuous
            .Weight = xlW
            .ColorIndex = xlAutomatic
        End With
    End With
End Sub

Private Sub RangeBordersInside(Rng As Range, xlW As Long)
On Error Resume Next
    With Rng
        With .Borders(xlInsideVertical)
            .LineStyle = xlContinuous
            .Weight = xlW
            .ColorIndex = xlAutomatic
        End With
        With .Borders(xlInsideHorizontal)
            .LineStyle = xlContinuous
            .Weight = xlW
            .ColorIndex = xlAutomatic
        End With
    End With
End Sub

'Sub ttt()
'   Set objExcel = New Excel.Application
'   Set wbhidden = objExcel.Workbooks.Open("c:\Macros\Primeri\Excel\check.xls")
'
'     Cells(1, 10).Value = wbhidden.Sheets(1).Cells(1, 1)
'
'     wbhidden.Close ' обязательно при выходе из кода
'   Set objExcel = Nothing  ' обязательно при выходе из кода
'End Sub

'openxlsb = Application _
'                .GetOpenFilename("Файл-источник (*.xls), *.xls")
'Set xlsb = Workbooks.Open(Filename:=openxlsb, ReadOnly:=True)
Изменено: under32 - 13.07.2020 14:03:34
Проблема использования ссылки на активную книгу в vba, Не могу понять почему vba не ссылается на активный лист открытой книги
 
Здравствуйте, спасибо Вам огромное, это работает
Проблема использования ссылки на активную книгу в vba, Не могу понять почему vba не ссылается на активный лист открытой книги
 
Здравствуйте, помогите разобраться, я пишу код vba в книги, и хочу сослаться на данные, которые находятся в другой книге( которая, сейчас открыта), на ее лист у меня не получается. Буду рад за помощь в решении проблемы и в понимание vba
Код
Sub CompareSub()
Dim ACell As Variant
Dim BCell As Variant

Application.ScreenUpdating = False
 For Each ACell In Workbook("1234.xlsm").Sheet("4456").Range("B5", Cells(Rows.Count, 2).End(xlUp))
    For Each BCell In Range("f1", Cells(Rows.Count, 6).End(xlUp))
    
     If BCell.Value = ACell.Value Then
     BCell.Interior.Color = 5296275
     Else
     ACell.Interior.Color = xlNone
     End If
     
    Next
Next
 Application.ScreenUpdating = True
End Sub
Извлечь уникальные
 
Здравствуйте, а есть возможность закрепить данный макрос на работу в определённом диапазоне, чтоб всегда работал на определенный диапазон.
Копирование данных по дате и ФИО с листа на форму
 
Спасибо, все работает  
Копирование данных по дате и ФИО с листа на форму
 
Спасибо, за подсказку, я данную формулу находил но проблема в том, что там данные будут заполнятся в итоге будет по 50 тыс. строк и она очень долго работает. Я бы видимо, больше хотел найти решения на базе VBA, я нашел пример на сайте по переносу на другой лист по дате, но не могу допереть какк поставить ещё один критерии.
Код
Sub SERZH() 'http://www.planetaexcel.ru/forum.php?thread_id=31559
Dim iLastRow As Long, jLastRow As Long, i As Long, DateStart As Date, DateFinish As Date
DateStart = [E1]
DateFinish = [G1]
iLastRow = Cells(Rows.Count, 2).End(xlUp).Row
    With Sheets("Ëèñò2")
        jLastRow = .Cells(Rows.Count, 2).End(xlUp).Row
'        .Range(.Cells(8, 1), .Cells(jLastRow + 2, 14)).ClearContents
'Íåìíîãî èñïðàâèì ýòó ñòðîêó: áóäåì î÷èùàòü ÂѨ (è ôîðìàòû)
        .Range(.Cells(8, 1), .Cells(jLastRow + 2, 14)).Clear
        jLastRow = 7
        For i = 8 To iLastRow
            If Cells(i, 4) >= DateStart Then
                If Cells(i, 4) <= DateFinish Then
'                    Range(Cells(i, 1), Cells(i, 14)).Copy .Cells(jLastRow + 1, 1) 'Ñêîëüêî ïåðåíîñòñÿ ñòîëáöîâ
'                    .Cells(jLastRow + 1, 14).Value = Cells(i, 14).Value
                    .Range(.Cells(jLastRow + 1, 1), .Cells(jLastRow + 1, 14)).Value = Range(Cells(i, 1), Cells(i, 14)).Value
                    jLastRow = jLastRow + 1
                End If
            End If
        Next
        .Cells(jLastRow + 1, 1) = "ÐÀÇÎÌ:"
        .Cells(jLastRow + 1, 8) = Application.WorksheetFunction.Sum(Range(.Cells(8, 8), .Cells(jLastRow + 1, 8)))
        .Cells(jLastRow + 1, 9) = Application.WorksheetFunction.Sum(Range(.Cells(8, 9), .Cells(jLastRow + 1, 9)))
        .Cells(jLastRow + 1, 10) = Application.WorksheetFunction.Sum(Range(.Cells(8, 10), .Cells(jLastRow + 1, 10)))
        .Cells(jLastRow + 1, 12) = Application.WorksheetFunction.Sum(Range(.Cells(8, 12), .Cells(jLastRow + 1, 12)))
        .Cells(jLastRow + 1, 14) = Application.WorksheetFunction.Sum(Range(.Cells(8, 14), .Cells(jLastRow + 1, 14)))
        .Range(.Cells(8, 1), .Cells(jLastRow + 1, 14)).Borders.LineStyle = xlContinuous 'Ðèñóåì ãðàíèöû
        .Range(.Cells(jLastRow + 1, 1), .Cells(jLastRow + 1, 14)).Font.Bold = True 'Äåëàåì â ïîñëåäíåé ñòðîêå æèðíûé øðèôò
    End With
End Sub
Копирование данных по дате и ФИО с листа на форму
 
Здравствуйте, в прикрепленном файле указал, по сути должны копироваться все строки в определенном интервале и которые в содержат ФИО (лист1  столбец F), если не получается без дня недели в итоговой форме может содержаться и день недели это не критично. Спасибо Вам за ответ.
Копирование данных по дате и ФИО с листа на форму
 
Здравствуйте, помогите пожалуйста решить задачу, облазил форму но решения не нашел, в vba пока ещё туплю. Есть задача переноса данных из строк по критерию ФИО и даты, которые устанавливаются в другом листе. Файл с примером прикреплен. С уважением и заранее всем спасибо, Игорь  
Страницы: 1
Наверх