Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1
RSS
При объеденении двух макросов выдает ошибку
 
#1
16.03.2020 11:28:54
Добрый день! при объеденении двух макросов выдает ошибу

Первый макрос (перенсит таблицу в новую книгу:
Код
    Cells.Select
    Selection.Copy
    Workbooks.Add
    ActiveSheet.Paste
    Range("A1").Select

Второй делит лист на указанное колличество строк и схраняет

Код
Dim iY1 As Long
    Dim iY2 As Long
    Dim i As Byte
    Dim sh1 As Worksheet
    Dim s As String
    Set sh1 = ActiveWorkbook.ActiveSheet
    
    i = 0
    
    For iY1 = 1 To Cells(Rows.Count, 2).End(xlUp).Row Step cDelta
        i = i + 1
        Workbooks.Add
        With sh1: .Range(.Cells(iY1, 1), .Cells(iY1 + cDelta - 1, Columns.Count)).Copy Cells(1): End With
        Rows(1).Insert Shift:=xlDown
        
        s = Replace(ThisWorkbook.FullName, ".xls", "-" & Right("0" & CStr(i), 2) & ".xls")
        
        ActiveWorkbook.SaveAs Filename:=s, FileFormat:= _
        xlExcel8, Password:="", WriteResPassword:="", _
        ReadOnlyRecommended:=False, CreateBackup:=False
        ActiveWorkbook.Close
    Next
после объеденения пояаляется ошибка, подсвечивает строку:

Код
        With sh1: .Range(.Cells(iY1, 1), .Cells(iY1 + cDelta - 1, Columns.Count)).Copy Cells(1): End With
 
 
 
#2
16.03.2020 11:31:21
Код
Dim iY1 As Long
    Dim iY2 As Long
    Dim i As Byte
    Dim sh1 As Worksheet
    Dim s As String
    Set sh1 = ActiveWorkbook.ActiveSheet

   'переносим ячейки листа, с которого был запуск в новую книгу
    Workbooks.Add
    sh1.Cells.Copy Range("A1")
     
    i = 0
     
    For iY1 = 1 To Cells(Rows.Count, 2).End(xlUp).Row Step cDelta
        i = i + 1
        Workbooks.Add
        With sh1: .Range(.Cells(iY1, 1), .Cells(iY1 + cDelta - 1, Columns.Count)).Copy Cells(1): End With
        Rows(1).Insert Shift:=xlDown
         
        s = Replace(ThisWorkbook.FullName, ".xls", "-" & Right("0" & CStr(i), 2) & ".xls")
         
        ActiveWorkbook.SaveAs Filename:=s, FileFormat:= _
        xlExcel8, Password:="", WriteResPassword:="", _
        ReadOnlyRecommended:=False, CreateBackup:=False
        ActiveWorkbook.Close
    Next
Даже самый простой вопрос можно превратить в огромную проблему. Достаточно не уметь формулировать вопросы...
 
 
 
#3
16.03.2020 12:04:34
Дмитрий(The_Prist) Щербаков, Спасибо!
 
 
 
#4
16.03.2020 12:43:21
Часть макроса я незаметил !

Объеденить нужно

1 макрос:
Код
    Selection.Copy
    Workbooks.Add
   
    ActiveSheet.Paste
   
    Columns("C:C").Select
    Range("C:C").Activate
    Selection.Replace What:="LookAt:=xlPart", Replacement:="", LookAt:=xlPart _
        , SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
   
    Columns("K:K").Select
    Selection.ClearContents

2 макрос:

Код
Option Explicit

Const cDelta = 2000

Sub RazdeLit()
    Dim iY1 As Long
    Dim iY2 As Long
    Dim i As Byte
    Dim sh1 As Worksheet
    Dim s As String
    Set sh1 = ActiveWorkbook.ActiveSheet
    
    'переносим ячейки листа, с которого был запуск в новую книгу
    Workbooks.Add
    sh1.Cells.Copy Range("A1")
    
    i = 0
    
    For iY1 = 1 To Cells(Rows.Count, 2).End(xlUp).Row Step cDelta
        i = i + 1
        Workbooks.Add
        With sh1: .Range(.Cells(iY1, 1), .Cells(iY1 + cDelta - 1, Columns.Count)).Copy Cells(1): End With
        Rows(1).Insert shift:=xlDown
        
        s = "D:\1234567890\04 - Щ\" & Replace(ThisWorkbook.Name, ".xls", "-" & Right("0" & CStr(i), 2) & ".xls")
        
        ActiveWorkbook.SaveAs Filename:=s, FileFormat:= _
        xlExcel8, Password:="", WriteResPassword:="", _
        ReadOnlyRecommended:=False, CreateBackup:=False
        ActiveWorkbook.Close
    Next
 
 
 
#5
16.03.2020 14:04:58
Такая деталь - Columns.Count у sh1 может быть неожиданно неожиданным :(
Необходимо синхронизировать, а в коде этого нет.
 
 
 
#6
16.03.2020 15:57:11
При объеденении выдает ошибку:
Цитата
Compile error:
Invalid inside procedure
Подсвечивает : Option Explicit
 
 
 
#7
16.03.2020 17:36:53
Цитата
nicex написал:
Часть макроса я незаметил
нехилую такую часть. Вы где эти части берете-то? Такое ощущение, что где-то на распродажах, раз свои же коды смогли как-то "не заметить"
Цитата
nicex написал:
При объеденении выдает ошибку
Вот по тексту ошибки: у Вас Option Explicit либо два раза записан, либо записан не в области объявлений, а между двумя кодами. Но мы этого не видим и не узнаем, т.к. нам Вы эту информацию не даете. Вы нам даете какие-то непонятные куски, а не полноценные макросы и даже не показываете что в итоге получилось. И текст ошибки в Яндекс тоже не пробовали запихнуть и поискать. Как помогать-то?
Даже самый простой вопрос можно превратить в огромную проблему. Достаточно не уметь формулировать вопросы...
 
 
 
#8
16.03.2020 17:48:39
Первый макрос:


Код
 
Sub dfgfh()

    Cells.Select
    Selection.Copy
    Workbooks.Add
    
    ActiveSheet.Paste
    
    Columns("C:C").Select
    Range("C:C").Activate
    Selection.Replace What:="LookAt:=xlPart", Replacement:="", LookAt:=xlPart _
        , SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
    
    Columns("K:K").Select
    Selection.ClearContents

End Sub


Второй (     "Option Explicit" и "Const cDelta = 2000" - было вынесено перед "Sub RazdeLit()" поэтому к сожалению не заметил:

Код
   

    Option Explicit
 
    Const cDelta = 2000
 
Sub RazdeLit()


    Dim iY1 As Long
    Dim iY2 As Long
    Dim i As Byte
    Dim sh1 As Worksheet
    Dim s As String
    Set sh1 = ActiveWorkbook.ActiveSheet
     
    'переносим ячейки листа, с которого был запуск в новую книгу
    Workbooks.Add
    sh1.Cells.Copy Range("A1")
     
    i = 0
     
    For iY1 = 1 To Cells(Rows.Count, 2).End(xlUp).Row Step cDelta
        i = i + 1
        Workbooks.Add
        With sh1: .Range(.Cells(iY1, 1), .Cells(iY1 + cDelta - 1, Columns.Count)).Copy Cells(1): End With
        Rows(1).Insert shift:=xlDown
         
        s = "C:\Users\RRR\Desktop\prices" & Replace(ThisWorkbook.Name, ".xls", "-" & Right("0" & CStr(i), 2) & ".xls")
         
        ActiveWorkbook.SaveAs Filename:=s, FileFormat:= _
        xlExcel8, Password:="", WriteResPassword:="", _
        ReadOnlyRecommended:=False, CreateBackup:=False
        ActiveWorkbook.Close
    Next

End Sub
 
 
 
#9
16.03.2020 17:58:53
Я лично не очень понимаю какие манипуляции и где здесь должны производиться, поэтому тупо объединил два кода(с небольшими изменениями в виде избавления от всяких Select), как и просили:
Код
Option Explicit  
Const cDelta = 2000
  
Sub RazdeLit()
 
 
    Dim iY1 As Long
    Dim iY2 As Long
    Dim i As Byte
    Dim sh1 As Worksheet
    Dim s As String
    Set sh1 = ActiveWorkbook.ActiveSheet
      
    'переносим ячейки листа, с которого был запуск в новую книгу
    Workbooks.Add
    sh1.Cells.Copy Range("A1")
    Columns("C:C").Replace What:="LookAt:=xlPart", Replacement:="", LookAt:=xlPart _
        , SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
    Columns("K:K").ClearContents
      
    i = 0
      
    For iY1 = 1 To Cells(Rows.Count, 2).End(xlUp).Row Step cDelta
        i = i + 1
        Workbooks.Add
        With sh1: .Range(.Cells(iY1, 1), .Cells(iY1 + cDelta - 1, Columns.Count)).Copy Cells(1): End With
        Rows(1).Insert shift:=xlDown
          
        s = "C:\Users\RRR\Desktop\prices" & Replace(ThisWorkbook.Name, ".xls", "-" & Right("0" & CStr(i), 2) & ".xls")
          
        ActiveWorkbook.SaveAs Filename:=s, FileFormat:= _
        xlExcel8, Password:="", WriteResPassword:="", _
        ReadOnlyRecommended:=False, CreateBackup:=False
        ActiveWorkbook.Close
    Next
 
End Sub
что там в итоге будет работать и как я не знаю
Даже самый простой вопрос можно превратить в огромную проблему. Достаточно не уметь формулировать вопросы...
 
 
 
#10
16.03.2020 18:20:15
Первый макрос работает самостоятельно:

Код
Dim sSubStr As String 
    Dim lCol As Long 
    Dim lLastRow As Long, li As Long
    Dim arr
 
    sSubStr = "Z"
    lCol = 11
    If lCol = 0 Then Exit Sub
 
    lLastRow = ActiveSheet.UsedRange.Row - 1 + ActiveSheet.UsedRange.Rows.Count
    arr = Cells(1, lCol).Resize(lLastRow).Value
 
    Application.ScreenUpdating = 0
    Dim rr As Range
    For li = 1 To lLastRow
        If CStr(arr(li, 1)) = sSubStr Then
            If rr Is Nothing Then
                Set rr = Cells(li, 1)
            Else
                Set rr = Union(rr, Cells(li, 1))
            End If
        End If
    Next li
    If Not rr Is Nothing Then rr.EntireRow.Copy
    'Application.ScreenUpdating = 1
'End Sub


    Workbooks.Add 
    
    ActiveSheet.Paste 
    
    Columns("C:C").Select 
    Range("C:C").Activate
    Selection.Replace What:="LookAt:=xlPart", Replacement:="", LookAt:=xlPart _
        , SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
    
    Columns("K:K").Select 
    Selection.ClearContents

И второй который делит на строки тоже:

Код
Option Explicit

Const cDelta = 2000

Sub i____СТРОКИ()
    Dim iY1 As Long
    Dim iY2 As Long
    Dim i As Byte
    Dim sh1 As Worksheet
    Dim s As String
    Set sh1 = ActiveWorkbook.ActiveSheet
    
    i = 0
    
    For iY1 = 1 To Cells(Rows.Count, 2).End(xlUp).Row Step cDelta
        i = i + 1
        Workbooks.Add
        With sh1: .Range(.Cells(iY1, 1), .Cells(iY1 + cDelta - 1, Columns.Count)).Copy Cells(1): End With
        Rows(1).Insert shift:=xlDown
        
        s = Replace(ThisWorkbook.FullName, ".xls", "-" & Right("0" & CStr(i), 2) & ".xls")
        
        ActiveWorkbook.SaveAs Filename:=s, FileFormat:= _
        xlExcel8, Password:="", WriteResPassword:="", _
        ReadOnlyRecommended:=False, CreateBackup:=False
        ActiveWorkbook.Close
    Next

End Sub



А если объединить не работают!
 
 
 
#11
16.03.2020 18:26:04
Вы посмотрите по теме какие коды Вы приводите и просите объединить и какие в последнем сообщении. Опять малюсенькую часть макроса не заметили и "не работает"? И не будет, пока порядок не наведете хотя бы перед созданием тем.
Лично мне уже надоело с таким Вашим подходом соединять какие-то нелепо брошенные на форум куски в единое целое. Ждите, может у кого проявится интерес.
Даже самый простой вопрос можно превратить в огромную проблему. Достаточно не уметь формулировать вопросы...
 
 
 
#12
16.03.2020 18:31:06
Дмитрий(The_Prist) Щербаков, на этот раз полностью оба макроса выложил, не хотел загромождать, как правило ошибка составления кода обнаруживается сразу
 
 
 
#13
16.03.2020 19:56:20
А зачем их вообще объединять ? Запускайте по очереди.
 
 
 
#14
16.03.2020 20:21:55
Наколхозить это мы за всегда
Код
Sub Макрос3 ()
       Макрос1
       Макрос2
End Sub
Изменено: nicex - 17.03.2020 12:07:38
 
 
 
Страницы: 1
Наверх