Домашняя страница Undo Do New Save Карта сайта Обратная связь Поиск по форуму
МИР MS EXCEL - Гость.xls

Вход

Регистрация

Напомнить пароль

 

= Мир MS Excel/Вставка доп листов в имеющийся код - Мир MS Excel

Старая форма входа
  • Страница 1 из 1
  • 1
Модератор форума: китин, _Boroda_, DrMini  
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Вставка доп листов в имеющийся код (Формулы)
Вставка доп листов в имеющийся код
sibtherm Дата: Суббота, 25.01.2014, 15:57 | Сообщение № 1
Группа: Пользователи
Ранг: Новичок
Сообщений: 11
Репутация: 0 ±
Замечаний: 40% ±

Excel 2007
Дорогие друзья требуется помощь.
Имеется файл с кодом VBA, который по заданным параметрам копирует и вставляет листы в исходный файл.
Теперь потребовалось вставить в исходный файл еще несколько листов с теоретическими данными, но если просто вставлять или создавать листы, то код их удаляет. Вставить надо листы между файлами "Отчет" и "Фото1". Прошу откликнуться. Файлы в приложении не прикрепляются весят много. могу выслать на почту.
 
Ответить
СообщениеДорогие друзья требуется помощь.
Имеется файл с кодом VBA, который по заданным параметрам копирует и вставляет листы в исходный файл.
Теперь потребовалось вставить в исходный файл еще несколько листов с теоретическими данными, но если просто вставлять или создавать листы, то код их удаляет. Вставить надо листы между файлами "Отчет" и "Фото1". Прошу откликнуться. Файлы в приложении не прикрепляются весят много. могу выслать на почту.
Автор - sibtherm
Дата добавления - 25.01.2014 в 15:57
sibtherm Дата: Воскресенье, 26.01.2014, 08:30 | Сообщение № 2
Группа: Пользователи
Ранг: Новичок
Сообщений: 11
Репутация: 0 ±
Замечаний: 40% ±

Excel 2007
[vba]
Код
Option Explicit

Sub CopySheets(wbTo As Workbook, wbFrom As Workbook, arr, i%)
Dim w As Worksheet, j%
wbFrom.Sheets(arr).Copy after:=wbTo.Sheets(wbTo.Sheets.Count)
If i > 1 Then
For Each w In wbTo.Sheets(arr)
For j = wbTo.Sheets.Count To 5 Step -1
If wbTo.Sheets(j).Name Like (w.Name & "#") Then w.Move after:=wbTo.Sheets(j): GoTo nxSheet
Next
If w.Name = "Граф" Then
For j = wbTo.Sheets.Count To 5 Step -1
If wbTo.Sheets(j).Name Like "РК*" Then w.Move after:=wbTo.Sheets(j): GoTo nxSheet
Next
End If
nxSheet:
Next
End If
End Sub

Sub main()
Dim i%, j%, sTmp$, sDir$, twb As Workbook, wb(1 To 4) As Workbook
Dim arr1(), arr2(), arr(), aWS, tCalc, w As Worksheet
arr1 = Array("Фото", "ТР", "СВ", "РК", "Эконом", "Экология", "Расчеты")
arr2 = Array("Фото", "ТР", "СВ", "РК", "Граф", "Эконом", "Экология", "Расчеты")

On Error Resume Next
Application.ScreenUpdating = False
tCalc = Application.Calculation
Application.Calculation = xlCalculationAutomatic

Set twb = ThisWorkbook
If twb.Sheets.Count > 4 Then
Application.DisplayAlerts = False
For i = twb.Sheets.Count To 5 Step -1
If twb.Sheets(i).Name Like "Расчеты*" Then twb.Sheets(i).Visible = True
twb.Sheets(i).Delete
Next
Application.DisplayAlerts = True
End If

sDir = twb.Path
For i = 1 To [дКотловГл].Value
If IsNumeric(Range("дИсп_" & i).Text) Then
If data.Cells(i * 3 + 6, "L").Text <> "-" Then
sTmp = data.Cells(i * 3 + 6, "L").Text & ".xls"
Set wb(i) = Workbooks(sTmp)
If Err.Number = 9 Then
Set wb(i) = Workbooks.Open(sDir & "\" & sTmp)
End If

If sTmp = "КП - Г1.xls" Or sTmp = "КП - Дт1.xls" Then arr = arr1 Else arr = arr2
Call CopySheets(twb, wb(i), arr, i)

For Each aWS In arr
twb.Sheets(aWS).Name = aWS & i
twb.Sheets(aWS & i).UsedRange.Replace What:="_t", Replacement:="Гл", LookAt:=xlPart ', LookIn:=xlFormulas
twb.Sheets(aWS & i).UsedRange.Replace What:="_", Replacement:="_" & i, LookAt:=xlPart ', LookIn:=xlFormulas
Next
For j = twb.Names.Count To 1 Step -1
If Right(twb.Names(j).Name, 1) = "_" Or Right(twb.Names(j).Name, 2) = "_t" Then twb.Names(j).Delete
Next
twb.BreakLink Name:=sDir & "\" & sTmp, Type:=xlExcelLinks
twb.Save
End If
End If
Next
For i = 1 To [дКотловГл].Value
If Not wb(i) Is Nothing Then wb(i).Close False
Next

For Each w In twb.Sheets
If w.Name Like "Расчеты*" Then w.Visible = xlSheetVeryHidden
Next

data.Activate
Application.Calculation = tCalc
Application.ScreenUpdating = True
End Sub
[/vba]

Это весь код. Вот здесь надо что то изменить чтобы вставить в исходный файл еще 7 листов чтобы они были стационары, и уже после них код вставлял необходимые данные.
 
Ответить
Сообщение[vba]
Код
Option Explicit

Sub CopySheets(wbTo As Workbook, wbFrom As Workbook, arr, i%)
Dim w As Worksheet, j%
wbFrom.Sheets(arr).Copy after:=wbTo.Sheets(wbTo.Sheets.Count)
If i > 1 Then
For Each w In wbTo.Sheets(arr)
For j = wbTo.Sheets.Count To 5 Step -1
If wbTo.Sheets(j).Name Like (w.Name & "#") Then w.Move after:=wbTo.Sheets(j): GoTo nxSheet
Next
If w.Name = "Граф" Then
For j = wbTo.Sheets.Count To 5 Step -1
If wbTo.Sheets(j).Name Like "РК*" Then w.Move after:=wbTo.Sheets(j): GoTo nxSheet
Next
End If
nxSheet:
Next
End If
End Sub

Sub main()
Dim i%, j%, sTmp$, sDir$, twb As Workbook, wb(1 To 4) As Workbook
Dim arr1(), arr2(), arr(), aWS, tCalc, w As Worksheet
arr1 = Array("Фото", "ТР", "СВ", "РК", "Эконом", "Экология", "Расчеты")
arr2 = Array("Фото", "ТР", "СВ", "РК", "Граф", "Эконом", "Экология", "Расчеты")

On Error Resume Next
Application.ScreenUpdating = False
tCalc = Application.Calculation
Application.Calculation = xlCalculationAutomatic

Set twb = ThisWorkbook
If twb.Sheets.Count > 4 Then
Application.DisplayAlerts = False
For i = twb.Sheets.Count To 5 Step -1
If twb.Sheets(i).Name Like "Расчеты*" Then twb.Sheets(i).Visible = True
twb.Sheets(i).Delete
Next
Application.DisplayAlerts = True
End If

sDir = twb.Path
For i = 1 To [дКотловГл].Value
If IsNumeric(Range("дИсп_" & i).Text) Then
If data.Cells(i * 3 + 6, "L").Text <> "-" Then
sTmp = data.Cells(i * 3 + 6, "L").Text & ".xls"
Set wb(i) = Workbooks(sTmp)
If Err.Number = 9 Then
Set wb(i) = Workbooks.Open(sDir & "\" & sTmp)
End If

If sTmp = "КП - Г1.xls" Or sTmp = "КП - Дт1.xls" Then arr = arr1 Else arr = arr2
Call CopySheets(twb, wb(i), arr, i)

For Each aWS In arr
twb.Sheets(aWS).Name = aWS & i
twb.Sheets(aWS & i).UsedRange.Replace What:="_t", Replacement:="Гл", LookAt:=xlPart ', LookIn:=xlFormulas
twb.Sheets(aWS & i).UsedRange.Replace What:="_", Replacement:="_" & i, LookAt:=xlPart ', LookIn:=xlFormulas
Next
For j = twb.Names.Count To 1 Step -1
If Right(twb.Names(j).Name, 1) = "_" Or Right(twb.Names(j).Name, 2) = "_t" Then twb.Names(j).Delete
Next
twb.BreakLink Name:=sDir & "\" & sTmp, Type:=xlExcelLinks
twb.Save
End If
End If
Next
For i = 1 To [дКотловГл].Value
If Not wb(i) Is Nothing Then wb(i).Close False
Next

For Each w In twb.Sheets
If w.Name Like "Расчеты*" Then w.Visible = xlSheetVeryHidden
Next

data.Activate
Application.Calculation = tCalc
Application.ScreenUpdating = True
End Sub
[/vba]

Это весь код. Вот здесь надо что то изменить чтобы вставить в исходный файл еще 7 листов чтобы они были стационары, и уже после них код вставлял необходимые данные.
Автор - sibtherm
Дата добавления - 26.01.2014 в 08:30
KuklP Дата: Воскресенье, 26.01.2014, 10:21 | Сообщение № 3
Группа: Проверенные
Ранг: Старожил
Сообщений: 2369
Репутация: 486 ±
Замечаний: 0% ±

2003-2010
Во-первых, это не весь код. Этот код не самостоятельный, он вызывается другим кодом. Во-вторых, почему бы Вам не запаковать файлы-примеры(небольшие) в рар и не выложить здесь? Это существенно ускорит решение, уверяю Вас.

Ну с НДС и мы чего-то стoим! kuklp60@gmail.com
WM Z206653985942, R334086032478, U238399322728
 
Ответить
СообщениеВо-первых, это не весь код. Этот код не самостоятельный, он вызывается другим кодом. Во-вторых, почему бы Вам не запаковать файлы-примеры(небольшие) в рар и не выложить здесь? Это существенно ускорит решение, уверяю Вас.
Автор - KuklP
Дата добавления - 26.01.2014 в 10:21
sibtherm Дата: Воскресенье, 26.01.2014, 17:34 | Сообщение № 4
Группа: Пользователи
Ранг: Новичок
Сообщений: 11
Репутация: 0 ±
Замечаний: 40% ±

Excel 2007
Согласен. Попробовал создать архивы.
Архив с именем "Котел промышленный" это как раз основной рабочий файл.
КП-Г2 это одна из схем для работы.
В основном рабочем файле, после листа отчет, надо вставить еще 7 пустых листов с названиями Теор,Резул,Выводы,Прил,Спец,СХ,Метод, наполнять их буду потом.
но главное чтобы код остался рабочим, чтобы после 7 пустого листа с названием Метод, код вставлял требуемые данные.
Заранее огромная благодарность.
К сообщению приложен файл: 3285443.rar (94.3 Kb)
 
Ответить
СообщениеСогласен. Попробовал создать архивы.
Архив с именем "Котел промышленный" это как раз основной рабочий файл.
КП-Г2 это одна из схем для работы.
В основном рабочем файле, после листа отчет, надо вставить еще 7 пустых листов с названиями Теор,Резул,Выводы,Прил,Спец,СХ,Метод, наполнять их буду потом.
но главное чтобы код остался рабочим, чтобы после 7 пустого листа с названием Метод, код вставлял требуемые данные.
Заранее огромная благодарность.
Автор - sibtherm
Дата добавления - 26.01.2014 в 17:34
sibtherm Дата: Воскресенье, 26.01.2014, 17:36 | Сообщение № 5
Группа: Пользователи
Ранг: Новичок
Сообщений: 11
Репутация: 0 ±
Замечаний: 40% ±

Excel 2007
еще один архив с рабочей схемой
К сообщению приложен файл: -2.rar (27.8 Kb)
 
Ответить
Сообщениееще один архив с рабочей схемой
Автор - sibtherm
Дата добавления - 26.01.2014 в 17:36
KuklP Дата: Воскресенье, 26.01.2014, 20:18 | Сообщение № 6
Группа: Проверенные
Ранг: Старожил
Сообщений: 2369
Репутация: 486 ±
Замечаний: 0% ±

2003-2010
[vba]
Код
Sub main()
      Dim i&, j&, sTmp$, sDir$, twb As Workbook, wb(1 To 4) As Workbook
      Dim arr1(), arr2(), arr(), aWS, tCalc, w As Worksheet
      Set twb = ThisWorkbook
      On Error Resume Next
      Application.ScreenUpdating = False

      arr1 = Array("Теор", "Резул", "Выводы", "Прил", "Спец", "СХ", "Метод")
      For i = 6 To 0 step -1
          twb.Worksheets.Add(after:=twb.Worksheets("Отчет")).Name = arr1(i)
      Next
      arr1 = Array("Фото", "ТР", "СВ", "РК", "Эконом", "Экология", "Расчеты")
      arr2 = Array("Фото", "ТР", "СВ", "РК", "Граф", "Эконом", "Экология", "Расчеты")

      tCalc = Application.Calculation
      Application.Calculation = xlCalculationAutomatic

      If twb.Sheets.Count > 4 Then
          Application.DisplayAlerts = False
          For i = twb.Sheets.Count To 5 Step -1
              If twb.Sheets(i).Name Like "Расчеты*" Then twb.Sheets(i).Visible = True
              twb.Sheets(i).Delete
          Next
          Application.DisplayAlerts = True
      End If

      sDir = twb.Path
      For i = 1 To [дКотловГл].Value
          If IsNumeric(Range("дИсп_" & i).Text) Then
              If data.Cells(i * 3 + 6, "L").Text <> "-" Then
                  sTmp = data.Cells(i * 3 + 6, "L").Text & ".xls"
                  Set wb(i) = Workbooks(sTmp)
                  If Err.Number = 9 Then
                      Set wb(i) = Workbooks.Open(sDir & "\" & sTmp)
                  End If

                  If sTmp = "КП - Г1.xls" Or sTmp = "КП - Дт1.xls" Then arr = arr1 Else arr = arr2
                  Call CopySheets(twb, wb(i), arr, i)

                  For Each aWS In arr
                      twb.Sheets(aWS).Name = aWS & i
                      twb.Sheets(aWS & i).UsedRange.Replace What:="_t", Replacement:="Гл", LookAt:=xlPart    ', LookIn:=xlFormulas
                      twb.Sheets(aWS & i).UsedRange.Replace What:="_", Replacement:="_" & i, LookAt:=xlPart    ', LookIn:=xlFormulas
                  Next
                  For j = twb.Names.Count To 1 Step -1
                      If Right(twb.Names(j).Name, 1) = "_" Or Right(twb.Names(j).Name, 2) = "_t" Then twb.Names(j).Delete
                  Next
                  twb.BreakLink Name:=sDir & "\" & sTmp, Type:=xlExcelLinks
                  twb.Save
              End If
          End If
      Next
      For i = 1 To [дКотловГл].Value
          If Not wb(i) Is Nothing Then wb(i).Close False
      Next

      For Each w In twb.Sheets
          If w.Name Like "Расчеты*" Then w.Visible = xlSheetVeryHidden
      Next

      data.Activate
      Application.Calculation = tCalc
      Application.ScreenUpdating = True
End Sub
[/vba]

Ну с НДС и мы чего-то стoим! kuklp60@gmail.com
WM Z206653985942, R334086032478, U238399322728

Сообщение отредактировал KuklP - Воскресенье, 26.01.2014, 20:44
 
Ответить
Сообщение[vba]
Код
Sub main()
      Dim i&, j&, sTmp$, sDir$, twb As Workbook, wb(1 To 4) As Workbook
      Dim arr1(), arr2(), arr(), aWS, tCalc, w As Worksheet
      Set twb = ThisWorkbook
      On Error Resume Next
      Application.ScreenUpdating = False

      arr1 = Array("Теор", "Резул", "Выводы", "Прил", "Спец", "СХ", "Метод")
      For i = 6 To 0 step -1
          twb.Worksheets.Add(after:=twb.Worksheets("Отчет")).Name = arr1(i)
      Next
      arr1 = Array("Фото", "ТР", "СВ", "РК", "Эконом", "Экология", "Расчеты")
      arr2 = Array("Фото", "ТР", "СВ", "РК", "Граф", "Эконом", "Экология", "Расчеты")

      tCalc = Application.Calculation
      Application.Calculation = xlCalculationAutomatic

      If twb.Sheets.Count > 4 Then
          Application.DisplayAlerts = False
          For i = twb.Sheets.Count To 5 Step -1
              If twb.Sheets(i).Name Like "Расчеты*" Then twb.Sheets(i).Visible = True
              twb.Sheets(i).Delete
          Next
          Application.DisplayAlerts = True
      End If

      sDir = twb.Path
      For i = 1 To [дКотловГл].Value
          If IsNumeric(Range("дИсп_" & i).Text) Then
              If data.Cells(i * 3 + 6, "L").Text <> "-" Then
                  sTmp = data.Cells(i * 3 + 6, "L").Text & ".xls"
                  Set wb(i) = Workbooks(sTmp)
                  If Err.Number = 9 Then
                      Set wb(i) = Workbooks.Open(sDir & "\" & sTmp)
                  End If

                  If sTmp = "КП - Г1.xls" Or sTmp = "КП - Дт1.xls" Then arr = arr1 Else arr = arr2
                  Call CopySheets(twb, wb(i), arr, i)

                  For Each aWS In arr
                      twb.Sheets(aWS).Name = aWS & i
                      twb.Sheets(aWS & i).UsedRange.Replace What:="_t", Replacement:="Гл", LookAt:=xlPart    ', LookIn:=xlFormulas
                      twb.Sheets(aWS & i).UsedRange.Replace What:="_", Replacement:="_" & i, LookAt:=xlPart    ', LookIn:=xlFormulas
                  Next
                  For j = twb.Names.Count To 1 Step -1
                      If Right(twb.Names(j).Name, 1) = "_" Or Right(twb.Names(j).Name, 2) = "_t" Then twb.Names(j).Delete
                  Next
                  twb.BreakLink Name:=sDir & "\" & sTmp, Type:=xlExcelLinks
                  twb.Save
              End If
          End If
      Next
      For i = 1 To [дКотловГл].Value
          If Not wb(i) Is Nothing Then wb(i).Close False
      Next

      For Each w In twb.Sheets
          If w.Name Like "Расчеты*" Then w.Visible = xlSheetVeryHidden
      Next

      data.Activate
      Application.Calculation = tCalc
      Application.ScreenUpdating = True
End Sub
[/vba]
Автор - KuklP
Дата добавления - 26.01.2014 в 20:18
sibtherm Дата: Воскресенье, 26.01.2014, 20:46 | Сообщение № 7
Группа: Пользователи
Ранг: Новичок
Сообщений: 11
Репутация: 0 ±
Замечаний: 40% ±

Excel 2007
Выдает ошибку:

If sTmp = "КП - Г1.xls" Or sTmp = "КП - Дт1.xls" Then arr = arr1 Else arr = arr2
Call CopySheets(twb, wb(i), arr,i)

Пишет ByRef argument type mismatch
 
Ответить
СообщениеВыдает ошибку:

If sTmp = "КП - Г1.xls" Or sTmp = "КП - Дт1.xls" Then arr = arr1 Else arr = arr2
Call CopySheets(twb, wb(i), arr,i)

Пишет ByRef argument type mismatch
Автор - sibtherm
Дата добавления - 26.01.2014 в 20:46
KuklP Дата: Воскресенье, 26.01.2014, 20:48 | Сообщение № 8
Группа: Проверенные
Ранг: Старожил
Сообщений: 2369
Репутация: 486 ±
Замечаний: 0% ±

2003-2010
Забыл, поменяйте типы переменных:
[vba]
Код
Sub CopySheets(wbTo As Workbook, wbFrom As Workbook, arr, i&)
   Dim w As Worksheet, j&
[/vba]

Ну с НДС и мы чего-то стoим! kuklp60@gmail.com
WM Z206653985942, R334086032478, U238399322728
 
Ответить
СообщениеЗабыл, поменяйте типы переменных:
[vba]
Код
Sub CopySheets(wbTo As Workbook, wbFrom As Workbook, arr, i&)
   Dim w As Worksheet, j&
[/vba]
Автор - KuklP
Дата добавления - 26.01.2014 в 20:48
sibtherm Дата: Воскресенье, 26.01.2014, 20:53 | Сообщение № 9
Группа: Пользователи
Ранг: Новичок
Сообщений: 11
Репутация: 0 ±
Замечаний: 40% ±

Excel 2007
Неа, не захотел.
Я создал за листом отчет те листы которые надо.
Код запустился, но листы не остались. он их удалил.
 
Ответить
СообщениеНеа, не захотел.
Я создал за листом отчет те листы которые надо.
Код запустился, но листы не остались. он их удалил.
Автор - sibtherm
Дата добавления - 26.01.2014 в 20:53
KuklP Дата: Воскресенье, 26.01.2014, 21:04 | Сообщение № 10
Группа: Проверенные
Ранг: Старожил
Сообщений: 2369
Репутация: 486 ±
Замечаний: 0% ±

2003-2010
Я дотуда не дошел :D
[vba]
Код
Sub main()
     Dim i&, j&, sTmp$, sDir$, twb As Workbook, wb(1 To 4) As Workbook
     Dim arr1(), arr2(), arr(), aWS, tCalc, w As Worksheet
     Set twb = ThisWorkbook
     On Error Resume Next
     Application.ScreenUpdating = False

     arr1 = Array("Теор", "Резул", "Выводы", "Прил", "Спец", "СХ", "Метод")
     For i = 0 To 6
         twb.Worksheets.Add(after:=twb.Worksheets("Отчет")).Name = arr1(i)
     Next
     arr1 = Array("Фото", "ТР", "СВ", "РК", "Эконом", "Экология", "Расчеты")
     arr2 = Array("Фото", "ТР", "СВ", "РК", "Граф", "Эконом", "Экология", "Расчеты")

     tCalc = Application.Calculation
     Application.Calculation = xlCalculationAutomatic

     If twb.Sheets.Count > 11 Then
         Application.DisplayAlerts = False
         For i = twb.Sheets.Count To 12 Step -1
             If twb.Sheets(i).Name Like "Расчеты*" Then twb.Sheets(i).Visible = True
             twb.Sheets(i).Delete
         Next
         Application.DisplayAlerts = True
     End If

     sDir = twb.Path
     For i = 1 To [дКотловГл].Value
         If IsNumeric(Range("дИсп_" & i).Text) Then
             If data.Cells(i * 3 + 6, "L").Text <> "-" Then
                 sTmp = data.Cells(i * 3 + 6, "L").Text & ".xls"
                 Set wb(i) = Workbooks(sTmp)
                 If Err.Number = 9 Then
                     Set wb(i) = Workbooks.Open(sDir & "\" & sTmp)
                 End If

                 If sTmp = "КП - Г1.xls" Or sTmp = "КП - Дт1.xls" Then arr = arr1 Else arr = arr2
                 Call CopySheets(twb, wb(i), arr, i)

                 For Each aWS In arr
                     twb.Sheets(aWS).Name = aWS & i
                     twb.Sheets(aWS & i).UsedRange.Replace What:="_t", Replacement:="Гл", LookAt:=xlPart    ', LookIn:=xlFormulas
                     twb.Sheets(aWS & i).UsedRange.Replace What:="_", Replacement:="_" & i, LookAt:=xlPart    ', LookIn:=xlFormulas
                 Next
                 For j = twb.Names.Count To 1 Step -1
                     If Right(twb.Names(j).Name, 1) = "_" Or Right(twb.Names(j).Name, 2) = "_t" Then twb.Names(j).Delete
                 Next
                 twb.BreakLink Name:=sDir & "\" & sTmp, Type:=xlExcelLinks
                 twb.Save
             End If
         End If
     Next
     For i = 1 To [дКотловГл].Value
         If Not wb(i) Is Nothing Then wb(i).Close False
     Next

     For Each w In twb.Sheets
         If w.Name Like "Расчеты*" Then w.Visible = xlSheetVeryHidden
     Next

     data.Activate
     Application.Calculation = tCalc
     Application.ScreenUpdating = True
End Sub
[/vba]

Ну с НДС и мы чего-то стoим! kuklp60@gmail.com
WM Z206653985942, R334086032478, U238399322728
 
Ответить
СообщениеЯ дотуда не дошел :D
[vba]
Код
Sub main()
     Dim i&, j&, sTmp$, sDir$, twb As Workbook, wb(1 To 4) As Workbook
     Dim arr1(), arr2(), arr(), aWS, tCalc, w As Worksheet
     Set twb = ThisWorkbook
     On Error Resume Next
     Application.ScreenUpdating = False

     arr1 = Array("Теор", "Резул", "Выводы", "Прил", "Спец", "СХ", "Метод")
     For i = 0 To 6
         twb.Worksheets.Add(after:=twb.Worksheets("Отчет")).Name = arr1(i)
     Next
     arr1 = Array("Фото", "ТР", "СВ", "РК", "Эконом", "Экология", "Расчеты")
     arr2 = Array("Фото", "ТР", "СВ", "РК", "Граф", "Эконом", "Экология", "Расчеты")

     tCalc = Application.Calculation
     Application.Calculation = xlCalculationAutomatic

     If twb.Sheets.Count > 11 Then
         Application.DisplayAlerts = False
         For i = twb.Sheets.Count To 12 Step -1
             If twb.Sheets(i).Name Like "Расчеты*" Then twb.Sheets(i).Visible = True
             twb.Sheets(i).Delete
         Next
         Application.DisplayAlerts = True
     End If

     sDir = twb.Path
     For i = 1 To [дКотловГл].Value
         If IsNumeric(Range("дИсп_" & i).Text) Then
             If data.Cells(i * 3 + 6, "L").Text <> "-" Then
                 sTmp = data.Cells(i * 3 + 6, "L").Text & ".xls"
                 Set wb(i) = Workbooks(sTmp)
                 If Err.Number = 9 Then
                     Set wb(i) = Workbooks.Open(sDir & "\" & sTmp)
                 End If

                 If sTmp = "КП - Г1.xls" Or sTmp = "КП - Дт1.xls" Then arr = arr1 Else arr = arr2
                 Call CopySheets(twb, wb(i), arr, i)

                 For Each aWS In arr
                     twb.Sheets(aWS).Name = aWS & i
                     twb.Sheets(aWS & i).UsedRange.Replace What:="_t", Replacement:="Гл", LookAt:=xlPart    ', LookIn:=xlFormulas
                     twb.Sheets(aWS & i).UsedRange.Replace What:="_", Replacement:="_" & i, LookAt:=xlPart    ', LookIn:=xlFormulas
                 Next
                 For j = twb.Names.Count To 1 Step -1
                     If Right(twb.Names(j).Name, 1) = "_" Or Right(twb.Names(j).Name, 2) = "_t" Then twb.Names(j).Delete
                 Next
                 twb.BreakLink Name:=sDir & "\" & sTmp, Type:=xlExcelLinks
                 twb.Save
             End If
         End If
     Next
     For i = 1 To [дКотловГл].Value
         If Not wb(i) Is Nothing Then wb(i).Close False
     Next

     For Each w In twb.Sheets
         If w.Name Like "Расчеты*" Then w.Visible = xlSheetVeryHidden
     Next

     data.Activate
     Application.Calculation = tCalc
     Application.ScreenUpdating = True
End Sub
[/vba]
Автор - KuklP
Дата добавления - 26.01.2014 в 21:04
sibtherm Дата: Воскресенье, 26.01.2014, 21:21 | Сообщение № 11
Группа: Пользователи
Ранг: Новичок
Сообщений: 11
Репутация: 0 ±
Замечаний: 40% ±

Excel 2007
Прогресс есть!
Листы остались, но вставляет их он в обратном порядке т.е за листом отчет сначала появляется Метод, СХ, Спец и т.д
и делает он это через раз
т.е один раз вставляет с названиями, второй раз просто с названиме Лист 146, и если повторить еще 2 раза то следующий раз пишет Лист 190 для листа Теор.
 
Ответить
СообщениеПрогресс есть!
Листы остались, но вставляет их он в обратном порядке т.е за листом отчет сначала появляется Метод, СХ, Спец и т.д
и делает он это через раз
т.е один раз вставляет с названиями, второй раз просто с названиме Лист 146, и если повторить еще 2 раза то следующий раз пишет Лист 190 для листа Теор.
Автор - sibtherm
Дата добавления - 26.01.2014 в 21:21
KuklP Дата: Воскресенье, 26.01.2014, 21:37 | Сообщение № 12
Группа: Проверенные
Ранг: Старожил
Сообщений: 2369
Репутация: 486 ±
Замечаний: 0% ±

2003-2010
Замените
[vba]
Код
For i = 0 To 6
[/vba]
на
[vba]
Код
For i = 6 To 0 Step -1
[/vba] Или поменяйте порядок в
[vba]
Код
    arr1 = Array("Теор", "Резул", "Выводы", "Прил", "Спец", "СХ", "Метод")
[/vba]
на обратный. А то, что через раз, так это правильно. Программа пытается присвоить листу имя, к-рое уже существует, возникает ошибка и этот шаг пропускается. Ладно, сделаю с проверкой:
[vba]
Код
Sub main()
     Dim i&, j&, sTmp$, sDir$, twb As Workbook, wb(1 To 4) As Workbook
     Dim arr1(), arr2(), arr(), aWS, tCalc, w As Worksheet
     Set twb = ThisWorkbook
     On Error Resume Next
     Application.ScreenUpdating = False

     arr1 = Array("Теор", "Резул", "Выводы", "Прил", "Спец", "СХ", "Метод")
     For i = 6 To 0 Step -1
         Set w = Worksheets(arr1(i))
         If w Is Nothing Then _
            twb.Worksheets.Add(after:=twb.Worksheets("Отчет")).Name = arr1(i)
         Set w = Nothing
     Next
     arr1 = Array("Фото", "ТР", "СВ", "РК", "Эконом", "Экология", "Расчеты")
     arr2 = Array("Фото", "ТР", "СВ", "РК", "Граф", "Эконом", "Экология", "Расчеты")

     tCalc = Application.Calculation
     Application.Calculation = xlCalculationAutomatic

     If twb.Sheets.Count > 11 Then
         Application.DisplayAlerts = False
         For i = twb.Sheets.Count To 12 Step -1
             If twb.Sheets(i).Name Like "Расчеты*" Then twb.Sheets(i).Visible = True
             twb.Sheets(i).Delete
         Next
         Application.DisplayAlerts = True
     End If

     sDir = twb.Path
     For i = 1 To [дКотловГл].Value
         If IsNumeric(Range("дИсп_" & i).Text) Then
             If data.Cells(i * 3 + 6, "L").Text <> "-" Then
                 sTmp = data.Cells(i * 3 + 6, "L").Text & ".xls"
                 Set wb(i) = Workbooks(sTmp)
                 If Err.Number = 9 Then
                     Set wb(i) = Workbooks.Open(sDir & "\" & sTmp)
                 End If

                 If sTmp = "КП - Г1.xls" Or sTmp = "КП - Дт1.xls" Then arr = arr1 Else arr = arr2
                 Call CopySheets(twb, wb(i), arr, i)

                 For Each aWS In arr
                     twb.Sheets(aWS).Name = aWS & i
                     twb.Sheets(aWS & i).UsedRange.Replace What:="_t", Replacement:="Гл", LookAt:=xlPart    ', LookIn:=xlFormulas
                     twb.Sheets(aWS & i).UsedRange.Replace What:="_", Replacement:="_" & i, LookAt:=xlPart    ', LookIn:=xlFormulas
                 Next
                 For j = twb.Names.Count To 1 Step -1
                     If Right(twb.Names(j).Name, 1) = "_" Or Right(twb.Names(j).Name, 2) = "_t" Then twb.Names(j).Delete
                 Next
                 twb.BreakLink Name:=sDir & "\" & sTmp, Type:=xlExcelLinks
                 twb.Save
             End If
         End If
     Next
     For i = 1 To [дКотловГл].Value
         If Not wb(i) Is Nothing Then wb(i).Close False
     Next

     For Each w In twb.Sheets
         If w.Name Like "Расчеты*" Then w.Visible = xlSheetVeryHidden
     Next

     data.Activate
     Application.Calculation = tCalc
     Application.ScreenUpdating = True
End Sub
[/vba]

Ну с НДС и мы чего-то стoим! kuklp60@gmail.com
WM Z206653985942, R334086032478, U238399322728
 
Ответить
СообщениеЗамените
[vba]
Код
For i = 0 To 6
[/vba]
на
[vba]
Код
For i = 6 To 0 Step -1
[/vba] Или поменяйте порядок в
[vba]
Код
    arr1 = Array("Теор", "Резул", "Выводы", "Прил", "Спец", "СХ", "Метод")
[/vba]
на обратный. А то, что через раз, так это правильно. Программа пытается присвоить листу имя, к-рое уже существует, возникает ошибка и этот шаг пропускается. Ладно, сделаю с проверкой:
[vba]
Код
Sub main()
     Dim i&, j&, sTmp$, sDir$, twb As Workbook, wb(1 To 4) As Workbook
     Dim arr1(), arr2(), arr(), aWS, tCalc, w As Worksheet
     Set twb = ThisWorkbook
     On Error Resume Next
     Application.ScreenUpdating = False

     arr1 = Array("Теор", "Резул", "Выводы", "Прил", "Спец", "СХ", "Метод")
     For i = 6 To 0 Step -1
         Set w = Worksheets(arr1(i))
         If w Is Nothing Then _
            twb.Worksheets.Add(after:=twb.Worksheets("Отчет")).Name = arr1(i)
         Set w = Nothing
     Next
     arr1 = Array("Фото", "ТР", "СВ", "РК", "Эконом", "Экология", "Расчеты")
     arr2 = Array("Фото", "ТР", "СВ", "РК", "Граф", "Эконом", "Экология", "Расчеты")

     tCalc = Application.Calculation
     Application.Calculation = xlCalculationAutomatic

     If twb.Sheets.Count > 11 Then
         Application.DisplayAlerts = False
         For i = twb.Sheets.Count To 12 Step -1
             If twb.Sheets(i).Name Like "Расчеты*" Then twb.Sheets(i).Visible = True
             twb.Sheets(i).Delete
         Next
         Application.DisplayAlerts = True
     End If

     sDir = twb.Path
     For i = 1 To [дКотловГл].Value
         If IsNumeric(Range("дИсп_" & i).Text) Then
             If data.Cells(i * 3 + 6, "L").Text <> "-" Then
                 sTmp = data.Cells(i * 3 + 6, "L").Text & ".xls"
                 Set wb(i) = Workbooks(sTmp)
                 If Err.Number = 9 Then
                     Set wb(i) = Workbooks.Open(sDir & "\" & sTmp)
                 End If

                 If sTmp = "КП - Г1.xls" Or sTmp = "КП - Дт1.xls" Then arr = arr1 Else arr = arr2
                 Call CopySheets(twb, wb(i), arr, i)

                 For Each aWS In arr
                     twb.Sheets(aWS).Name = aWS & i
                     twb.Sheets(aWS & i).UsedRange.Replace What:="_t", Replacement:="Гл", LookAt:=xlPart    ', LookIn:=xlFormulas
                     twb.Sheets(aWS & i).UsedRange.Replace What:="_", Replacement:="_" & i, LookAt:=xlPart    ', LookIn:=xlFormulas
                 Next
                 For j = twb.Names.Count To 1 Step -1
                     If Right(twb.Names(j).Name, 1) = "_" Or Right(twb.Names(j).Name, 2) = "_t" Then twb.Names(j).Delete
                 Next
                 twb.BreakLink Name:=sDir & "\" & sTmp, Type:=xlExcelLinks
                 twb.Save
             End If
         End If
     Next
     For i = 1 To [дКотловГл].Value
         If Not wb(i) Is Nothing Then wb(i).Close False
     Next

     For Each w In twb.Sheets
         If w.Name Like "Расчеты*" Then w.Visible = xlSheetVeryHidden
     Next

     data.Activate
     Application.Calculation = tCalc
     Application.ScreenUpdating = True
End Sub
[/vba]
Автор - KuklP
Дата добавления - 26.01.2014 в 21:37
sibtherm Дата: Воскресенье, 26.01.2014, 21:51 | Сообщение № 13
Группа: Пользователи
Ранг: Новичок
Сообщений: 11
Репутация: 0 ±
Замечаний: 40% ±

Excel 2007
Все отлично!
Листы остались, имена листов тоже, но вот порядок почему то до сих пор не поменялся.
Попробовал еще в добавку поменять порядок но результата не дало.
Что еще можно поправить?
 
Ответить
СообщениеВсе отлично!
Листы остались, имена листов тоже, но вот порядок почему то до сих пор не поменялся.
Попробовал еще в добавку поменять порядок но результата не дало.
Что еще можно поправить?
Автор - sibtherm
Дата добавления - 26.01.2014 в 21:51
KuklP Дата: Воскресенье, 26.01.2014, 21:56 | Сообщение № 14
Группа: Проверенные
Ранг: Старожил
Сообщений: 2369
Репутация: 486 ±
Замечаний: 0% ±

2003-2010
Позвольте Вам не поверить.

Вы ранее вставленные листы удаляли? Если нет, то программа их не тронет и они останутся в старом порядке.
К сообщению приложен файл: 9022381.rar (81.1 Kb) · 4579031.gif (23.1 Kb)

Ну с НДС и мы чего-то стoим! kuklp60@gmail.com
WM Z206653985942, R334086032478, U238399322728

Сообщение отредактировал KuklP - Воскресенье, 26.01.2014, 21:58
 
Ответить
СообщениеПозвольте Вам не поверить.

Вы ранее вставленные листы удаляли? Если нет, то программа их не тронет и они останутся в старом порядке.
Автор - KuklP
Дата добавления - 26.01.2014 в 21:56
sibtherm Дата: Воскресенье, 26.01.2014, 22:04 | Сообщение № 15
Группа: Пользователи
Ранг: Новичок
Сообщений: 11
Репутация: 0 ±
Замечаний: 40% ±

Excel 2007
Прописывал так как и говорили
[vba]
Код
arr1 = Array("Метод", "СХ", "Спец", "Прил", "Выводы", "Резул", "Теор")
For i = 6 To 0 Step -1
Set w = Worksheets(arr1(i))
If w Is Nothing Then _
twb.Worksheets.Add(after:=twb.Worksheets("Отчет")).Name = arr1(i)
Set w = Nothing
[/vba]

В приложении фото с экрана после пары запусков кода.
К сообщению приложен файл: 5121293.jpg (7.4 Kb)


Сообщение отредактировал Serge_007 - Воскресенье, 26.01.2014, 22:33
 
Ответить
СообщениеПрописывал так как и говорили
[vba]
Код
arr1 = Array("Метод", "СХ", "Спец", "Прил", "Выводы", "Резул", "Теор")
For i = 6 To 0 Step -1
Set w = Worksheets(arr1(i))
If w Is Nothing Then _
twb.Worksheets.Add(after:=twb.Worksheets("Отчет")).Name = arr1(i)
Set w = Nothing
[/vba]

В приложении фото с экрана после пары запусков кода.
Автор - sibtherm
Дата добавления - 26.01.2014 в 22:04
KuklP Дата: Воскресенье, 26.01.2014, 22:08 | Сообщение № 16
Группа: Проверенные
Ранг: Старожил
Сообщений: 2369
Репутация: 486 ±
Замечаний: 0% ±

2003-2010
Я писал:
Цитата KuklP, 26.01.2014 в 21:37, в сообщении № 12
For i = 6 To 0 Step -1 Или поменяйте порядок в
Вы сделали и то и другое. Если два раза изменить порядок на обратный, что получится? Распакуйте мой файл и запустите. Еще больше разжевать я не могу %)

Ну с НДС и мы чего-то стoим! kuklp60@gmail.com
WM Z206653985942, R334086032478, U238399322728
 
Ответить
СообщениеЯ писал:
Цитата KuklP, 26.01.2014 в 21:37, в сообщении № 12
For i = 6 To 0 Step -1 Или поменяйте порядок в
Вы сделали и то и другое. Если два раза изменить порядок на обратный, что получится? Распакуйте мой файл и запустите. Еще больше разжевать я не могу %)
Автор - KuklP
Дата добавления - 26.01.2014 в 22:08
sibtherm Дата: Воскресенье, 26.01.2014, 22:08 | Сообщение № 17
Группа: Пользователи
Ранг: Новичок
Сообщений: 11
Репутация: 0 ±
Замечаний: 40% ±

Excel 2007
Согласен и правда все ставит как надо!
Чем могу отблагодарить?
 
Ответить
СообщениеСогласен и правда все ставит как надо!
Чем могу отблагодарить?
Автор - sibtherm
Дата добавления - 26.01.2014 в 22:08
KuklP Дата: Воскресенье, 26.01.2014, 22:09 | Сообщение № 18
Группа: Проверенные
Ранг: Старожил
Сообщений: 2369
Репутация: 486 ±
Замечаний: 0% ±

2003-2010
Гы) А чем можете? Номера кошельков в подписи. :)

Ну с НДС и мы чего-то стoим! kuklp60@gmail.com
WM Z206653985942, R334086032478, U238399322728
 
Ответить
СообщениеГы) А чем можете? Номера кошельков в подписи. :)
Автор - KuklP
Дата добавления - 26.01.2014 в 22:09
sibtherm Дата: Воскресенье, 26.01.2014, 22:14 | Сообщение № 19
Группа: Пользователи
Ранг: Новичок
Сообщений: 11
Репутация: 0 ±
Замечаний: 40% ±

Excel 2007
Сори, с кошельками не знаком, как насчет мобильной связи?
 
Ответить
СообщениеСори, с кошельками не знаком, как насчет мобильной связи?
Автор - sibtherm
Дата добавления - 26.01.2014 в 22:14
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Вставка доп листов в имеющийся код (Формулы)
  • Страница 1 из 1
  • 1
Поиск:

Яндекс.Метрика Яндекс цитирования
© 2010-2025 · Дизайн: MichaelCH · Хостинг от uCoz · При использовании материалов сайта, ссылка на www.excelworld.ru обязательна!