Поиск  Пользователи  Правила 
Закрыть
Логин:
Пароль:
Забыли свой пароль?
Регистрация
Войти
 
Выбрать дату в календареВыбрать дату в календаре

Страницы: 1 2 3 След.
Сохранение столбцов таблицы как отдельных файлов
 
Поправил, как Вы просили
Сохранение столбцов таблицы как отдельных файлов
 
На скорую руку, пробуйте
Код
Sub aimv()
Dim ws As Worksheet
Dim wb As Workbook
Dim r As Range
Dim cc As Long, cr As Long
Dim i, x
Set wb = ActiveWorkbook
Application.ScreenUpdating = False
    cc = Cells(2, Columns.Count).End(xlToLeft).Column
    cr = Cells(Rows.Count, 2).End(xlUp).Row
        For i = 2 To cc
            If Cells(2, i).MergeCells = True Then
                x = Cells(2, i).MergeArea.Columns.Count
                Set r = Range(Cells(2, i), Cells(cr, x + 2 + i))
                Set ws = Sheets.Add(After:=Sheets(Sheets.Count))
                ws.Name = Sheets("Лист1").Cells(2, i).Value
                r.Copy Worksheets(ws.Name).Range("A1")
                Sheets("Лист1").Select
                i = i + x + 2
            End If
        Next i
For i = 2 To Sheets.Count
        x = Sheets(i).Name
        Sheets(i).Copy
        ActiveWorkbook.SaveAs wb.Path & "\" & x & ".xlsx"
        ActiveWorkbook.Close
Next i
Application.ScreenUpdating = True
End Sub
Горячая клавиша для знака "собачка"
 
На итальянской раскладке @ ставится правый Alt + ; У меня срабатывает.
Изменено: Ник Никитич - 19 Окт 2017 10:43:11
Объединение двух страниц по условию
 
Что надо делать, если в первой таблице нет данных, что есть во второй таблице?
Обновление 03.10.2017г., Обновил сервер, обновил Битрикс - тестируем
 
У меня уже другой раз вот такая ошибка при открытии страницы

При выполнении скрипта возникла ошибка. Включить расширенный вывод ошибок можно в файле настроек .settings.php
Fatal error: Uncaught Bitrix\Main\DB\SqlQueryException: Mysql query error: (2006) MySQL server has gone away in /home/bitrix/www/bitrix/modules/main/lib/db/mysqliconnection­.php:137 Stack trace: #0 /home/bitrix/www/bitrix/modules/main/lib/db/mysqlcommonconne­ction.php(132): Bitrix\Main\DB\MysqliConnection->queryInternal('SELECT * FROM `...') #1 /home/bitrix/www/bitrix/modules/main/lib/db/connection.php(715): Bitrix\Main\DB\MysqlCommonConnection->getTableFields('b_sec_session') #2 /home/bitrix/www/bitrix/modules/main/lib/db/sqlhelper.php(387): Bitrix\Main\DB\Connection->getTableField('b_sec_session', 'SESSION_ID') #3 /home/bitrix/www/bitrix/modules/main/lib/entity/datamanager.php(904): Bitrix\Main\DB\SqlHelper->prepareAssignment('b_sec_session', 'SESSION_ID', 'dp53Xza27nKblAP...') #4 /home/bitrix/www/bitrix/modules/security/classes/general/ses­sion_db.php(92): Bitrix\Main\Entity\DataManager::delete(Array) #5 [internal function]: CSecuritySessionDB::write('dp53Xza27nKblAP...', '') #6 [internal function]: session_write_close() in /home/bitrix/www/bitrix/modules/main/lib/db/mysqliconnection­.php on line 137
Скопировать строки листов книги по условию
 
В первом примере заберите Selection.AutoFilter
У Вас каждый лист должен идти в новую книгу?
Автоматический перенос нужных строк на отдельный лист
 
Подправил макрос Karataev, так нужно?
Код
Sub Перенести()
    Dim shSrc As Worksheet, arrSrc(), arrIsp(), shRes As Worksheet
    Dim lr As Long, r As Long, i As Long
    Application.ScreenUpdating = False
    Set shSrc = Worksheets("2017")
    Set shRes = Worksheets("Просрочка по контрактам")
    lr = shRes.Cells(shRes.Rows.Count, "A").End(xlUp).Row
    shRes.Rows("1:" & lr).Delete
    lr = shSrc.Cells(shSrc.Rows.Count, "A").End(xlUp).Row
    arrSrc() = shSrc.Range("T1:T" & lr).Value
    arrIsp() = shSrc.Range("Y1:Y" & lr).Value
    shSrc.Rows(1).Copy shRes.Cells(1, "A")
    r = 1
    For i = 2 To UBound(arrSrc)
        If arrSrc(i, 1) <> "" Then
            If arrSrc(i, 1) <= Date And arrIsp(i, 1) <> "ИСПОЛНЕН" Then
                r = r + 1
                shSrc.Rows(i).Copy shRes.Cells(r, "A")
            End If
        End If
    Next i
    shRes.Select
    Cells.EntireColumn.AutoFit
    Application.ScreenUpdating = True
End Sub
Заменить все отрицательные числа на странице на ноль
 
Вот так?
Код
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Value < 0 Then Target.Value = 0
End Sub
Помогите с таблицей учета больничных листов., копирование строк на второй лист
 
Надо чтобы со второго листа строки добавлялись в первый лист, при этом со второго удалялись, верно?
Переменная, содержащая количество строк на заданном листе
 
В Вашем третьем варианте после Cells точка не нужна  
Найти в столбце B пустые ячейки, удалить всю строку найденных ячеек - Макрос
 
Columns(2)
Нужна помощь в написании макроса на вывод данных с накладной в таблицу
 
На первую кнопку вот так можно
Код
Sub Reestr()
Dim ar()
iclr = ActiveWorkbook.Sheets("Реестр").Cells(Rows.Count, 2).End(xlUp).Row
ar = ActiveWorkbook.Sheets("Лист1").Range("B1:B7").Value
ActiveWorkbook.Sheets("Реестр").Cells(iclr + 1, 1).Resize(, 7).Value = Application.Transpose(ar())
End Sub

На вторую, постараюсь завтра
Добавить ячейки в таблицу
 
Пробуйте
Код
Sub kaktuz()
Dim iclr As Long
Dim i As Long
iclr = Cells(Rows.Count, 2).End(xlUp).Row
    For i = iclr To 2 Step -1
        Rows(i).Select
        ActiveCell.Resize(4).EntireRow.Insert
        Range(Cells(i, 2), Cells(i + 4, 2)).Merge
        Cells(i, 3).Resize(5, 1).Value = Application.Transpose(Array("элемент-1", "элемент-2", "элемент-3", "элемент-4", "элемент-5"))
    Next i
End Sub
Добавить ячейки в таблицу
 
Я думаю, что Hugo имел ввиду, что Вы запускаете макрорекодер, и добавляете ячейки вручную. Получаете макрос, делаете цикл на все ячейки, и получаете готовый макрос. Или прикрепите пример.
Добавить ячейки в таблицу
 
А как узнать количество ячеек, которые необходимо добавить? В вашем примере к первой ячейке добавили 5 ячеек, а во второй 4...
Как запретить редактировать строки по условию
 
Пробуйте
Как запретить редактировать строки по условию
 
Попробуйте добавить в модуль листа код
Код
Private Sub Worksheet_Change(ByVal Target As Range)
    Set Rng = Columns(1).Find(what:="OK", LookIn:=xlValues, lookAt:=xlWhole)
        If (Target.Column = 1) Then
            If IsEmpty(Target) = True Then
                ActiveSheet.Unprotect
            Exit Sub
            End If
        If Not Rng Is Nothing Then
            ActiveSheet.Unprotect
            With ActiveSheet
                .Range("B:Z").Locked = True
                .Protect
            End With
        Else
            ActiveSheet.Unprotect
        End If
    End If
End Sub
Просчет прироста в каждой второй строке (VBA/макрос), Нужна помощь
 
Прикрепите, пожалуйста, пример.
 
Форматировать прайс с помощью записи макроса, Пытаюсь отформатировать прайс с помощью записи макроса
 
Цитата
huchos написал:
если у товара нет артикула он становится заголовком
Так у вас примере было, поэтому я так это и прописал
Форматировать прайс с помощью записи макроса, Пытаюсь отформатировать прайс с помощью записи макроса
 
После     If Len(Cells(i, 1)) > 1 Then добавьте строку        Cells(i, 4).Value = Cells(i, 4) * 60
Форматировать прайс с помощью записи макроса, Пытаюсь отформатировать прайс с помощью записи макроса
 
Вот так надо?
Перенос текста на новую строку и добавление ячеек
 
Вот так? Поменял запятые и добавил End Sub
Код
Sub Resultat()
Dim i As Long
Dim j As Integer
Dim iLastRow As Long
Dim Kod1 As Integer
Dim Kod2
Dim iGruppa As String
  iLastRow = [B2].End(xlDown).Row
     For i = iLastRow To 3 Step -1
       If InStr(1, Cells(i, 4), " ") <> 0 Then
         Kod1 = Cells(i, 2)
         Kod2 = Split(Cells(i, 4), " ")
         iGruppa = Cells(i, 3)
         Set rng = Range(Cells(i, 5), Cells(i, 8)) 'добавил
         For j = 0 To UBound(Kod2)
           Rows(i + j).Insert
           Cells(i + j, 2) = Kod1
           Cells(i + j, 4) = Kod2(j)
           Cells(i + j, 3) = iGruppa
           Range(Cells(i + j, 5), Cells(i + j, 8)).Value = rng.Value 'добавил
         Next
           Rows(i + j).Delete
       End If
     Next i
End Sub
Изменено: Ник Никитич - 7 Мар 2017 15:03:16
Форматировать прайс с помощью записи макроса, Пытаюсь отформатировать прайс с помощью записи макроса
 
ActiveWindow.ScrollRow - эти строчки можете смело удалять, это скролл что вы делали
Вы лучше покажите прайс, и что хотите получить
Форматировать прайс с помощью записи макроса, Пытаюсь отформатировать прайс с помощью записи макроса
 
У Вас объединены ячейки, и поэтому Columns("B:E").Select выделяет столбец А, который потом Вы удаляете
Изменено: Ник Никитич - 7 Мар 2017 12:19:34
Перенос текста на новую строку и добавление ячеек
 
А в этой строке Вы поменяли запятую на пробел? Kod2 = Split(Cells(i, 4), " ")
Объединение таблиц из разных файлов Excel на один лист
 
Вот так?
Объединение таблиц из разных файлов Excel на один лист
 
Можете показать файл, куда собираются данные из всех таблиц
Примечание для ячейки макросом
 
Поменяйте предпоследнюю строку на
Код
cmt.Text Text:=Format(Now, strDate) & Chr(10) & cmt.Text '& Chr(10) - новая строка
Макрос суммирования в динамичных диапазонах
 
Пробуйте
Код
Sub www()
Dim i As Long
Dim y As Long
    For i = 12 To Range("a1").SpecialCells(xlLastCell).Row
        If InStr(Cells(i, 1), "Дата") > 0 Then
            For y = i + 1 To Range("a1").SpecialCells(xlLastCell).Row
                If InStr(Cells(y, 1), "Итого по абоненту") > 0 Then
                    Cells(y, 21).Value = Application.Sum(Range(Cells(i + 1, 21), Cells(y - 1, 21)))
                    i = y
                    Exit For
                End If
            Next y
        End If
    Next i
End Sub
Вставка строки с копированием данных
 
Так нужно?
Страницы: 1 2 3 След.
Наверх