Option Compare Text

Private Sub Worksheet_Change(ByVal Target As Range)


  If Not Intersect(Target, Range("A1")) Is Nothing Then
    
 
      If InStr(1, Range("A1"), "English") > 0 Then
        Range("C1").Value = "120"
      End If
      
      If InStr(1, Range("A1"), "German") > 0 Then
        Range("C1").Value = "90"
      End If
  
  End If

End Sub

Sub copycliensdata()

On Error Resume Next
Dim Data1folder, Data2folder
Dim oFD As FileDialog
Dim Myfile_Name, NewFile_Name As Variant
Dim mySh As Worksheet, ws As Worksheet
Dim Wbk As Workbook
Dim i As Long
Dim x&, Numrows&
Dim client$


        Data1folder = Application.GetOpenFilename _
                ("Excel files(*.xls*),*.xls*", 1, "Выбрать файл", , False)   'здесь выбираю файл где есть 20 вкладок, каждая вкладка с названием клиента
        If VarType(Data1folder) = vbBoolean Then
            Exit Sub
        End If



        With Workbooks.Open(Data1folder)                                               'формирую список клиентов
            For i = 1 To .Sheets.Count
                ThisWorkbook.Sheets("Macros").Cells(i, 10).Value = .Sheets(i).Name 'список клиентов
            Next
        End With

        Windows("Основной_файл.xlsb").Activate
        Numrows = Workbooks("Основной_файл.xlsb").Sheets("Macros").Range("J1", Range("J1").End(xlDown)).Rows.Count ' диапазон клиентов
            For x = 1 To Numrows
            With Worksheets("Macros")
                client = .Cells(x, 10).Value 'первый клиент из списка, 1-ый клиент с названием 987 ПАТ "МЕХАТРОНИК"
            End With

        Workbooks(Data1folder).Worksheets(client).Range("A1:B200").Copy   ' Здесь не находит клиента с названием 987 ПАТ "МЕХАТРОНИК" которое в переменной client
                                                                           А сам список формируется из названий тех же листов!!!!!
        Windows("Основной_файл.xlsb").Activate

       Sheets("Calculation").Select
        Cells.Select
        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                :=False, Transpose:=False
        ActiveSheet.Paste
        Application.CutCopyMode = False


End Sub

On Error Resume Next
Dim sFolder As String, sFiles As String
Dim MSdatafile


Data1Folder$ = GetFolder(1, , "Виберите папку с файлом")          ' путь 1 папка гдележит 1 файл у которого 20 вкладок
If InvoiceFolder$ = "" Then MsgBox "Не выбрано", vbCritical, "Завершено": Exit Sub

Data2Folder$ = GetFolder(1, , "Виберите папку с файлами")          ' путь 2
If InvoiceFolder$ = "" Then MsgBox "Не выбрано", vbCritical, "Завершено": Exit Sub

Data3Folder$ = GetFolder(2, , "Виберите папку куда сохранять файлы") ' путь 3
    If ArchieveFolder$ = "" Then MsgBox "Папка не задана", vbCritical, "Завершено": Exit Sub
Set sht = book.Sheets(

Numrows = Range("E2", Range("E2").End(xlDown)).Rows.Count ' диапазон названия клиентов
 
For x = 1 To Numrows
With sht
   
    arr = .Range(.Cells(2, 1), Cells(.UsedRange.Rows.Count, .UsedRange.Columns.Count))
End With


'-----------------------ШАГ ОДИН-----------------------
'Data1Folder$ тут лежит 1 файл где есть 20 вкладок, найти владку с названием из ячейки A1
Workbooks("Книга2.xlsx").Worksheets("Клиент1").Range("A1:T200").Copy  ' тут нужно сделать цикл а не жестко привязать название клиента
Windows("Книга1.xlsm").Activate                                 ' книга в которую копируем, расчетный файл
Sheets("Лист1").Select                                          ' вкладка куда копируем данные
Cells.Select                                                          ' диапазон куда копируем
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False                                     ' вставляем только значения
    ActiveSheet.Paste
Application.CutCopyMode = False                                       ' отменить выделенный диапазон


'-----------------------ШАГ ДВА-----------------------

    
' выбрать папку Data2Folder$ тут лежит 20 файлов из названиями. Нужно найти файл с названием из ячейки А1

Set wb = Application.Workbooks.Open(sFolder & sFiles)                 'здесь скорее всего неправильно
wb.Sheets(1).Range("A1:T200").Copy
Workbooks("Книга1.xlsm").Worksheets("Лист2").Range("A1").PasteSpecial Paste:=xlPasteValues ' куда копируем
Application.CutCopyMode = False                                       ' отменить выделенный диапазон
wb.Close True                                                         'закрыть файл откуда скопировали данные
        sFiles = Dir


'-----------------------ШАГ ТРИ-------------------------------
Windows("Книга1.xlsm").Activate                                 ' 
Sheets("Лист3").Select
Application.Calculate                 ' пересчитываем все формулы в Книге1
Data3Folder$ 'сюда сохраняем Лист3, с названием из ячейки А1, переименовываем Лист1 также на название с ячейки А1, обрываем связи
Workbooks("Книга1.xlsm").Worksheets("Лист3").SaveCopyAs Path & Имя_для_сохранения & ".xlsx" ' сохраняем 

Конец цикла, переходим к ячейке А2, делаем все то же, до конца списка клиентов.

End Sub

Sub Diapazon()

       For Each s In Range("A1:H100").Cells
       If s = "начало" Then
       'ActiveSheet.Cells(s.Row, s.Column).Select
       End If
   Next s
   
       For Each t In Range("A1:H100").Cells
       If s = "Итого" Then
       'ActiveSheet.Cells(s.Row, s.Column).Select
        End If
   Next t
   
      ActiveSheet.Range(Cells(t.Row, t.Column), Cells(s.Row, s.Column)).Copy

End Sub

Option Explicit
 
Sub Archives()
 
    On Error Resume Next
    Dim s7zipPath$, sArcPath$, sArcFile$, sDestPath$, sDelim$, CmdLine$
    Dim strDirPath$, strFileName$
    Dim strMaskSearch$
    Dim arr$(1), iPath$
    Dim x&, Numrows&, book As Workbook
    
    Application.ScreenUpdating = False 
    
    s7zipPath = "C:\Program Files\7-Zip\7z.exe" ' путь к архиватору 7zip
    
    Windows("Поиск файлов.xlsm").Activate
    Sheets("Limits").Select
    Numrows = Range("EE" & Rows.Count).End(xlUp).Row                              'диапазон ячеек с адресами 
    iPath = "D:\Companies\Statements\"                                            'корнева папка
     
    For x = 2 To Numrows
       
        Windows("Поиск файлов.xlsm").Activate
        Sheets("Limits").Select
        With Worksheets("Limits")
            arr(0) = .Cells(x, 135).Value                                               'адрес где искать архив, 1-ая часть адреса
            arr(1) = .Cells(x, 136).Value                                               'адрес где искать архив, 2-ая часть адреса
        End With
        strDirPath = iPath & arr(0) & "\" & arr(1) & "\"
        strMaskSearch = "*.zip*" And strMaskSearch = "*.rar*" And strMaskSearch = "*.7z*"   'возможные варианты архивов по указанному адресу
     
        sArcPath = strDirPath & strMaskSearch                                   ' путь к архиву
        sArcFile = "*#090*"                                                      ' имя 1 файла в архиве, который нужно распаковать (1)
        sArcaFile = "*#061*"                                                     ' имя 2 файла в архиве вариант 1, который нужно распаковать (2.1)
        sArccFile = "*#01S*"                                                     ' имя 2 файла в архиве вариант 2, который нужно распаковать (2.2)
        sArcbFile = "*#310*"                                                     ' имя 3 файла в архиве, который нужно распаковать (3)
        sDestPath = strDirPath                                                  ' путь к папке, куда распаковать файлы (полный или относительный)
    
        CmdLine = """" & s7zipPath & """" & " x " & """" & sArcPath & """" & " " & """" & sArcFile & """" & " -o" & """" & sDestPath & """" & " -y"  ' роспаковка(1)
        Shell CmdLine
        
        CmdLine = """" & s7zipPath & """" & " x " & """" & sArcPath & """" & " " & """" & sArcaFile & """" & " -o" & """" & sDestPath & """" & " -y" ' роспаковка(2.1)
        Shell CmdLine
    
        CmdLine = """" & s7zipPath & """" & " x " & """" & sArcPath & """" & " " & """" & sArccFile & """" & " -o" & """" & sDestPath & """" & " -y" ' роспаковка(2.2)
        Shell CmdLine
               
        CmdLine = """" & s7zipPath & """" & " x " & """" & sArcPath & """" & " " & """" & sArcbFile & """" & " -o" & """" & sDestPath & """" & " -y" 'роспаковка(3)
        Shell CmdLine
        
        'CreateObject("WScript.Shell").Run CmdLine, 1, True ' синхронный запуск
    
    Next

End Sub

Sub Searches2222()
 
Dim strDirPath, strMaskSearch, strFileName, K As String
Dim Folder As String
Dim Namebank As String
Dim balancedate As String
Dim ibook As Workbook
Dim arr() As Workbook
Dim oRange As Range
Dim x As Integer         'numrows число строк данных

Numrows = Range("A2", Range("A2").End(xlDown)).Rows.Count ' диапазон

Range("A2").Select
For x = 1 To Numrows ' следующая строка в диапазоне

iPath = "D\Мои документы\"

Name = "Письма"
    Folder = Worksheets(Name).Cells(2, 1).Value 'адрес
    Nameclient = Worksheets(Name).Cells(2, 2).Value 'название
    K = Worksheets(Name).Cells(2, 3).Value 'дата
 
strDirPath = iPath & "\" & Folder & "\" & Nameclient & "\"
strMaskSearch = "*#02*" 'Маска поиска
  
'Получаем первый файл соответствующий шаблону
strFileName = Dir(strDirPath & strMaskSearch)
'---------------- Открытие файла *.* ----------------------------------
    Workbooks.OpenText FileName:=strDirPath & strFileName, Origin:=xlMSDOS _
        , StartRow:=1, DataType:=xlFixedWidth, FieldInfo:=Array(Array(0, 1), Array( _
        10, 1))
 
 
[A:J].Copy Workbooks("Анализ.xlsm").Sheets("Лист1").[C1]

Windows("Анализ.xlsm").Activate
Sheets("Limits").Select
ActiveCell.Offset(1, 0).Select
    Next
    
End Sub

Sub Search()

Dim strDirPath, strMaskSearch, strFileName, a, d, K As String


Name = "Limits"
    a = Worksheets(Name).Cells(172, 6).Value 'адрес
    d = Worksheets(Name).Cells(173, 6).Value 'название
    K = Worksheets(Name).Cells(29, 4).Value 'дата 

strDirPath = "C:/Мои документы/a/d/" 'Папка поиска
strMaskSearch = "*02*" 'Маска поиска
 
'Получаем первый файл соответствующий шаблону
strFileName = Dir(strDirPath & strMaskSearch)
 
Do While strFileName <> "" 'До тех пор пока файлы "не закончатся"
    

'---------------- Открытие файла *.* ----------------------------------
    Workbooks.OpenText FileName:=strDirPath & strFileName, Origin:=xlMSDOS _
        , StartRow:=1, DataType:=xlFixedWidth, FieldInfo:=Array(Array(0, 1), Array( _
        10, 1))

    strFileName = Dir 'Следующий файл
Loop

Columns("A:J").Select
'    Selection.Cut
    
    Selection.Copy
    
    Windows("Riskovik_2.1.xlsm").Activate
    Sheets("Лист1").Select
    Range("C1").Select
    ActiveSheet.Paste
End Sub

strDirPath = "C:/Мои документы/a/d/" 'Папка поиска 

Sub FileOpen()
Application.ScreenUpdating = True
fileToOpen = Application _
    .GetOpenFilename("Все файлы (*.*), *.*", , "*** Ввод файла ***")
Application.ScreenUpdating = False
If fileToOpen <> False Then
'---------------- Открытие файла *.* ----------------------------------
    Workbooks.OpenText Filename:=fileToOpen, Origin:=xlMSDOS _
        , StartRow:=1, DataType:=xlFixedWidth, FieldInfo:=Array(Array(0, 1), Array( _
        10, 1))
End If

   Columns("A:J").Select
'    Selection.Cut
    
    Selection.Copy
    
    Windows("Копирование по списку").Activate
    Sheets("Лист1").Select
    Range("C1").Select
    ActiveSheet.Paste

Sub Макрос2()
Application.ScreenUpdating = True
fileToOpen = Application _
    .GetOpenFilename("Все файлы (*.*), *.*", , "*** Ввод файла ***")
Application.ScreenUpdating = False
If fileToOpen <> False Then
'---------------- Открытие файла *.* ----------------------------------
    Workbooks.OpenText Filename:=fileToOpen, Origin:=xlMSDOS _
        , StartRow:=1, DataType:=xlFixedWidth, FieldInfo:=Array(Array(0, 1), Array( _
        10, 1))
    
End If

   Columns("A:J").Select
'    Selection.Cut
    
    Selection.Copy
    
    Windows("Копирование по списку").Activate
    Sheets("Лист1").Select
    Range("C1").Select
    ActiveSheet.Paste


End Sub

ActiveWorkbook.SaveCopyAs Filename:="С:\Мои документы\" & a & "\" & d & "\" & d & "_" & k & ".xlsx"

Range("A1").Select

    Worksheets Данные.Select    
    Range(K5, Q15).Select
    Selection.Copy
    Worksheets Письма.Select
    Range(A1).Select

    Sheets("Данные").Select
    Range("K5:Q15").Select
    Selection.Copy
    Sheets("Письма").Select
    Range(A1).Select

Sub Макрос 2()
Application.ScreenUpdating = True
fileToOpen = Application _
    .GetOpenFilename("Все файлы (*.*), *.*", , "*** Ввод файла ***")
Application.ScreenUpdating = False
If fileToOpen <> False Then
'---------------- Открытие файла *.* ----------------------------------
    Workbooks.OpenText Filename:=fileToOpen, Origin:=xlMSDOS _
        , StartRow:=1, DataType:=xlFixedWidth, FieldInfo:=Array(Array(0, 1), Array( _
        10, 1))
    Else: IndOpen = 0
    
    If IndOpen = 1 Then GoTo Finita

    Columns("A:J").Select
'    Selection.Cut
    
    Selection.Copy
    
    Windows("Данные.xlsm").Activate
    Sheets("Лист1").Select
    Range("C1").Select
    ActiveSheet.Paste

Finita:
Application.ScreenUpdating = True
Sheets("Данные").Select

End If