1 (изменено: alexii, 2011-04-19 17:55:36)

Тема: VBA: непустые ячейки перенести на другой лист

Здравствуйте!

В чем же моя проблема, спросите вы. Проблема в том, что на первый лист файла я копирую данные по компаниям. Даты по вертикали меняются, и меняется количество компаний по горизонтали. Мне нужно, чтобы скрипт сам ловил количество компаний и выводил их в первой строке второго листа. То есть, если я скопировал данные по 30 (50 и т.д.) компаниям, то на втором листе в первой строке появляется 30 (50 и т.д.) стобцов. И потом считается среднее арифметическое по столбцам (для каждой компании). Просто сейчас мне приходится вручную копировать и заново вставлять на второй лист все данные.

Можно ли это сделать как-то автоматически?

Спасибо.

2

Re: VBA: непустые ячейки перенести на другой лист

Не совсем понятна задача и исходный формат данных, но осмелюсь подсказать.

Простой макрос, который копирует выделенный диапазон, создает новый лист и в него вставляет транспортированные данные (горизонталь -> вертикаль)

Sub TransposePasteNewSheet()
    Selection.Copy
    Sheets.Add After:=Sheets(Sheets.Count)
    
    Sheets(Sheets.Count).Range("A1").Select
    
    Selection.PasteSpecial _
        Paste:=xlPasteValues, _
        Operation:=xlNone, _
        SkipBlanks:=False, _
        Transpose:=True
End Sub

В принципе, не сложно автоматический поиск последнего не пустого столбца и подставить вместо Selection.Copy - Range...:

LastCol = Cells.Find("*", [A1], , , xlByColumns, xlPrevious).Column
// Если у носорога плохое зрение, то при его весе - это не его проблема.

3 (изменено: niydiyin, 2011-04-20 12:06:32)

Re: VBA: непустые ячейки перенести на другой лист

tankist, я попробовал Ваш первый скрипт - в итоге создается еще один лист, в котором только значение ячейки A1.
Я нашел еще один скрипт, вот он:

Sub bbb()
Лист2.UsedRange.Offset(0).Clear
    Dim ra As Range: Application.ScreenUpdating = False
    Set ra = Range([a1], Range("a" & Rows.Count).End(xlUp))
    ra.EntireRow.Copy Лист2.[a5]
    Лист2.Activate
End Sub

Этот скрипт всё ловит и вставляет на втором листе, но с ним есть проблемы:
1. Во-первых, если я в предпоследней строчке пишу не A5, а B5 (C3, J2, т. е. любой столбец кроме А), то он не работает
2. Он переносит все ячейки, а мне надо только первую строку.
3. И еще, после того, как я перенес названия компаний, мне надо на строке ниже осуществить поиск по дате такой формулой:

=ЕСЛИ(ВПР($B12;Sheet1!$A$1:$CX$123;C$10;ЛОЖЬ)<>"";ВПР($B12;Sheet1!$A$1:$CX$123;C$10;ЛОЖЬ);ЛОЖЬ())

B12 - это ячейка с датой, она уже есть на втором листе, с ней ничего делать не надо.

Извините, если не очень понятно объясняю. Можно ли как-то прикрепить файл?

4

Re: VBA: непустые ячейки перенести на другой лист

niydiyin, код оформляется тэгом «code». Я поправил Ваш пост.

niydiyin пишет:

Можно ли как-то прикрепить файл?

Нет. Упакуйте его в архив, выложите полученный архив на какой-либо файлообменник, ссылку — сюда.

5

Re: VBA: непустые ячейки перенести на другой лист

niydiyin пишет:

tankist, я попробовал Ваш первый скрипт - в итоге создается еще один лист, в котором только значение ячейки A1.

Второй код - не скрипт, формула автоматического поиска последнего непустого столбца от ячейки А1.

niydiyin пишет:

Этот скрипт всё ловит и вставляет на втором листе, но с ним есть проблемы:
1. Во-первых, если я в предпоследней строчке пишу не A5, а B5 (C3, J2, т. е. любой столбец кроме А), то он не работает
2. Он переносит все ячейки, а мне надо только первую строку.
3. И еще, после того, как я перенес названия компаний, мне надо на строке ниже осуществить поиск по дате такой формулой:

=ЕСЛИ(ВПР($B12;Sheet1!$A$1:$CX$123;C$10;ЛОЖЬ)<>"";ВПР($B12;Sheet1!$A$1:$CX$123;C$10;ЛОЖЬ);ЛОЖЬ())

B12 - это ячейка с датой, она уже есть на втором листе, с ней ничего делать не надо.

Sub test()
    Dim LastCol, diffCol
    LastCol = Cells.Find("*", [A1], , , xlByColumns, xlPrevious).Column
    ActiveCell.Resize(1, LastCol - Selection.Column + 1).Copy
    Sheets.Add After:=Sheets(Sheets.Count)
    Sheets(Sheets.Count).Range("A1").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=True, Transpose:=True
End Sub

В какой бы ты ячейке не находился, будут выбраны все ячейки в этой строке до последнего столбца, потом скопированы/вставлены значения с транспортировкой на новый лист. Макрос не оптимизирован, написан в качестве примера что надо делать.
Совсем не понял про формулу - зачем в строке ниже, когда мы из ряда сделали столбец. Под столбцом ставить? В формуле ВПР третьим значением должен стоять номер столбца, а не ссылка на ячейку, да и "ЛОЖЬ"/"ИСТИНА" можно писать 0 или 1. Намного проще визуально воспринимается .

// Если у носорога плохое зрение, то при его весе - это не его проблема.

6 (изменено: niydiyin, 2011-04-21 14:37:42)

Re: VBA: непустые ячейки перенести на другой лист

http://rghost.ru/5269961
это пример. там я уже сделал вставку строки, используя вот такой код

Sub test()
    Лист2.UsedRange.Clear
    Dim ra As Range: Application.ScreenUpdating = False
    Set ra = Range([c1], Range("iv1").End(xlToLeft))
    ra.Copy Лист2.[c11]
    Лист2.Activate
End Sub

ложь или истина мне нужны если нет значения, потому что если там будет 0 это уже число.
а в формуле там где ссылка на ячейку это и есть номер столбца, просто он задан в другой ячейке.
посмотрите, пожалуйста, пример. там всё достаточно просто, это просто я плохо объясняю


попробовал ваш скрипт - круто, действительно круто. только он зависит от того где курсор стоит.
вот я его изменил минимально

Dim LastCol, diffCol
    LastCol = Cells.Find("*", [A1], , , xlByColumns, xlPrevious).Column
    ActiveCell.Resize(1, LastCol - Selection.Column + 1).Copy
    Sheets.Add After:=Sheets(Sheets.Count)
    Sheets(Sheets.Count).Range("c11").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=True, Transpose:=False

вы можете мне объяснить построково, что тут происходит?


апгрейдил код, осталось только разобраться с формулой:

Sub forum()
Dim LastCol, diffCol, i, j As Integer, sum As Integer
    LastCol = Cells.Find("*", [A1], , , xlByColumns, xlPrevious).Column
    ActiveCell.Resize(1, LastCol - Selection.Column + 1).Copy
    Sheets.Add After:=Sheets(Sheets.Count)
    Sheets(Sheets.Count).Range("c11").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=True, Transpose:=False
    sum = 0
    Sheets(Sheets.Count).Range("c10").Select
    For i = 3 To LastCol
    sum = i
    Sheets(Sheets.Count).Cells(10, i) = sum
    Next i
    Sheets(Sheets.Count).Range("c12").Select
    For j = 3 To LastCol
    Sheets(Sheets.Count).Cells(12, j).FormulaLocal = "=ЕСЛИ(ВПР($A12;Лист1!$A$1:$O$15;C$10;ЛОЖЬ)<>"";ВПР($A12;Лист1!$A$1:$O$15;C$10;ЛОЖЬ);ЛОЖЬ())"
    Next j
End Sub

проблема в том, что в этой формуле должен меняться диапазон. то есть $A$1:$lastrow$lastcol
и ячейка (номер столбца) должна быть не C$10, а что-то типа сells(10,i).

7

Re: VBA: непустые ячейки перенести на другой лист

niydiyin, ссылки оформляем тэгом «url». Пишем по-русски, используя заглавные буквы и знаки препинания.

8

Re: VBA: непустые ячейки перенести на другой лист

ну так как?

9

Re: VBA: непустые ячейки перенести на другой лист

niydiyin пишет:

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

Там где Excel просит вставлять в формулу ЛОЖЬ или ИСТИНА (т.е. именно в том тесте), 0 - это ЛОЖЬ, 1 - это ИСТИНА. Так работает в английском Excel и этот приятный момент (так как формулы проще воспринимаются визуально) не трогают.
Касаемо номера столбца в виде ссылки - если что-то случится с столбцом, то все перестанет работать. Будет "#ССЫЛКА" в формулах, а это и её последствия, значительно трудней исправлять, нежели в формуле без ошибки поменять цифру. Но - это просто совет, я на "ВПР" три пуда соли съел, делюсь опытом :-).

niydiyin пишет:

вы можете мне объяснить построково, что тут происходит?

Dim LastCol, diffCol
    ' Перевенной LastCol задаётся значение номера последнего столбца с непустой ячейкой от А1 (т.е. получаем общее количество столбцов)
    LastCol = Cells.Find("*", [A1], , , xlByColumns, xlPrevious).Column
    ' От активной ячейки изменить область выделения на 1 строку и столбцов = всего столбов - номер активного столбца. выделенное копировать.
    ActiveCell.Resize(1, LastCol - Selection.Column + 1).Copy
    ' Добавить новый лист последним в списке
    Sheets.Add After:=Sheets(Sheets.Count)
    ' Выбрать ячейку в этом листе
    Sheets(Sheets.Count).Range("c11").Select
    ' VBA комманда выполненной операции "Вставить как..." с указанными параметрами "Только значения", "Транспортировать" и "Пропускать пустые"
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=True, Transpose:=False

Кривость макроса в алгоритме вычисления на сколько столбцов увеличиваться (найти последний от активной ячейки). Не было времени читать, а в VBA не так силен

niydiyin пишет:

апгрейдил код, осталось только разобраться с формулой:
....
проблема в том, что в этой формуле должен меняться диапазон. то есть $A$1:$lastrow$lastcol
и ячейка (номер столбца) должна быть не C$10, а что-то типа сells(10,i).

К сожалению, пример - удалён. Не успел посмотреть, а на словах понять задачу по названиям адресов ячеек - все-таки нереально :-).
Но если я правильно понял последнюю строку, то проблемы вроде как и нет. Используйте уже указанную переменную LastCall - сells(10,LastCall). Или делайте новый поиск...

// Если у носорога плохое зрение, то при его весе - это не его проблема.

10

Re: VBA: непустые ячейки перенести на другой лист

niydiyin, выложите, пожалуйста, пример рабочей книги ещё раз.

11 (изменено: niydiyin, 2011-04-29 11:10:55)

Re: VBA: непустые ячейки перенести на другой лист

tankist, спасибо Вам за объяснение. Я без ссылок на ячейки никак не обойдусь, потому что там номера не по порядку и протянуть формулу я могу только воспользовавшись ссылкой на ячейки. Знаю, что проблемно, но у меня там никаких операций не проводится с данными после их копирования, так что терпимо)
У меня такой вопрос, как сделать, чтобы макрос не зависел от того, какую я ячейку выделяю, а всегда начинал копировать информацию с ячейки C1? И еще, как сделать, чтобы каждый раз не создавался новый лист, а всегда обновлялась информация на Лист2, у меня там уже есть кое-какие данные, поэтому надо чтобы информация копировалась именно туда.

Dmitrii, tankist, вот примерчик опять залил:
http://rghost.ru/5385554

Самое главное всё равно остается формула, вообще не приложу ума как это сделать.

Вот, сделал ячейку, как еще сделать, чтобы на Лист2 всегда копировалось (это ко второму абзацу ):

Sub test()
    Dim LastCol, diffCol, i, j As Integer, sum As Integer
    LastCol = Cells.Find("*", [A1], , , xlByColumns, xlPrevious).Column
    Cells(1, 3).Resize(1, LastCol - Selection.Column + 1).Copy
    Sheets.Add After:=Sheets(Sheets.Count)
    Sheets(Sheets.Count).Range("c11").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=True, Transpose:=False
    sum = 0
    Sheets(Sheets.Count).Range("c10").Select
    For i = 3 To LastCol
    sum = i
    Sheets(Sheets.Count).Cells(10, i) = sum
    Next i
End Sub

12

Re: VBA: непустые ячейки перенести на другой лист

Не уверен что правильно уловил суть задачи. Исходя из первого поста и последней выложенной книги предполагаю:
1. На первый лист вручную копируются табличные данные(первая строка - Name, вторая - Code, дальше некие числовые данные).
2. Первая колонка содержит дату(неважно что за дата, главное что она есть всегда).
3. В результате обработки скопированных данных, на другом листе необходимо получить таблицу содержащую наименование и среднее арифметическое чисел по компании.
4. На исходный лист данные копируются вместо тех что там были. Это уже догадка - учитывая что данные располагаются горизонтально, работа с большим кол-вом данных будет очень неудобна(постоянный скроллинг по горизонтали).
5. Исходя из предпосылок п.4, предполагаю что данные со средним арифметическим также перезаписываются.

Предлагаю такой вариант макроса(запускать вручную):


Option Explicit
Sub CopyData()
 Dim SourceListCodeName: SourceListCodeName = "Лист1" 'CodeName целевого листа(aka "Name" в св-вах листа в редакторе макросов)
 'CodeName из Excel не переименовывается, поэтому изменение отображаемого имени листа (aka "(Name)" в св-вах листа
 'в редакторе макросов) не повлияет на работу макроса
 Dim TargetListCodeName: TargetListCodeName = "Лист2"
 
 Dim srcList, trgtList
 srcList = GetListName(SourceListCodeName)
 trgtList = GetListName(TargetListCodeName)
 'проверяем что листы указаны верно
 If IsBool(srcList) Then MsgBox "Имя листа-источника задано неправильно!", vbCritical
 If IsBool(trgtList) Then MsgBox "Имя целевого листа задано неправильно!", vbCritical
 If IsBool(srcList) Or IsBool(trgtList) Then Exit Sub
 
 Dim FirstColumn, FirstDataRow, NameDataRow, CodeDataRow
 'задаём формат данных(значения приведены для выложенной книги)
 FirstColumn = 1 'первая колонка диапазона
 FirstDataRow = 3 'первая строка с данными
 NameDataRow = FirstDataRow - 2 'строка с названиями
 CodeDataRow = FirstDataRow - 1 'строка с кодами
 
 'ищем последнюю строку с данными
 Dim i, j 'для циклов
 Dim tmp: tmp = "str"
 
 'на всякий случай ограничем обрабатываеммый массив(при поиске конца данных):
 Dim MaxRowIteration, MaxColumnIteration
 MaxRowIteration = 50 'ограничение при проходе строк
 MaxColumnIteration = 100 'ограничение при проходе столбцов
 Dim LastDataRow, LastDataColumn
 'перебираем строки в первой колонке пока не наткнёмся на пустую.
 i = FirstDataRow - 1
 Do
  i = i + 1
  tmp = Sheets(srcList).Cells(i, FirstColumn).Value
 Loop Until StrComp(tmp, "", vbTextCompare) = 0 Or IsNull(tmp) Or i = MaxRowIteration
 LastDataRow = i - 1 'запоминаем последнюю строку с данными
 
 'ищем последнюю колонку с данными(т.е. где указана и фирма и код)
 i = FirstColumn 'колонку дат(первая колонка диапазона) сразу пропускаем, поэтому без "-1"
 Do
    i = i + 1
  If Len(Sheets(srcList).Cells(NameDataRow, i).Value) > 0 And Len(Sheets(srcList).Cells(CodeDataRow, i).Value) > 0 Then
    tmp = True
   Else
    tmp = False
  End If
 Loop Until Not tmp Or i = MaxColumnIteration
 LastDataColumn = i - 1 'запоминаем последнюю колонку с данными
 
 'очищаем лист куда будем копировать данные
 Worksheets(trgtList).Cells.ClearContents
 'заполняем лист данными
 Dim k
 For i = FirstColumn + 1 To LastDataColumn 'колонка
  ' если нужно только название(код не нужен), то правим тут:
  Sheets(trgtList).Cells(1, i - FirstColumn).Value = Sheets(srcList).Cells(NameDataRow, i).Value & "[" & _
                                                     Sheets(srcList).Cells(CodeDataRow, i).Value & "]"
  tmp = 0: k = 0
  For j = FirstDataRow To LastDataRow 'строка
   tmp = tmp + Sheets(srcList).Cells(j, i).Value
   k = k + 1
   Debug.Print tmp
  Next
  Sheets(trgtList).Cells(2, i - FirstColumn) = tmp / k 'среднее арифметическое
 Next
 'автоподгонка ширины колонок под данные
 Worksheets(trgtList).Select
 With Worksheets(trgtList)
  .Cells.Select
  .Cells.EntireColumn.AutoFit
  .Cells(1, 1).Select
 End With
End Sub

Function IsBool(data)
 If StrComp(TypeName(data), "Boolean", vbTextCompare) = 0 Then
  IsBool = True
  Else
  IsBool = False
 End If
End Function

Function GetListName(ListCodeName)
 ' определяем отображаемое имя листа:
 Dim i
 For i = 1 To Sheets.Count
  If StrComp(ListCodeName, Sheets(i).CodeName, vbTextCompare) = 0 Then GetListName = Sheets(i).Name
 Next
 If Len(ListCodeName) = 0 Then GetListName = False
End Function

В макросе задаётся первая колонка диапазона, первая строка данных и внутреннее название листа источника и листа куда данные будут копироваться. Т.к. листы в макросе задаются явно, запускать его можно из любого места книги.

Сначала определяются границы данных(перебором), потом в рамках этих границ обрабатывается диапазон и результат заносится на целевой лист(который предварительно очищается от данных). В шапка формируется как  "Name[Code]". Если в последнем цикле поменять местами индексы ячеек, то данные транспонируются(мне кажется это будет удобнее для просмотра).

P.S. Мои предположения по п.4, 5 упрощают макрос, но при туманных исходных уславиях я всегда делаю предположения в пользу уменьшения моих трудозатрат

13

Re: VBA: непустые ячейки перенести на другой лист

BeS Yara, бегло посмотрел код, предложенный Вами в сообщении #12, и обнаружил в нём существенную ошибку.
Прошу не обижаться, "навожу критику" не для того, чтобы "насолить", но чтобы исправить неверное.

Алгоритм функции GetListName() ошибочен. Она вернёт значение FALSE лишь тогда, когда имя листа не задано вообще. Любое другое строковое (или даже числовое) значение сойдёт за имя имеющегося в книге листа.
Верный код должен выглядеть примерно так:

Function GetListName(ListCodeName)
' определяем отображаемое имя листа:
Dim i
GetListName = False
If Len(ListCodeName) > 0 Then
    For i = 1 To Worksheets.Count
        If StrComp(ListCodeName, Worksheets(i).CodeName, vbTextCompare) = 0 Then
            GetListName = Worksheets(i).Name
            Exit For
        End If
    Next
End If
End Function

Кроме того:
- имеется противоречивый или, по крайней мере, неоднозначно понимаемый комментарий:

BeS Yara пишет:

'CodeName целевого листа (aka "Name" в св-вах листа в редакторе макросов <...> изменение отображаемого имени листа (aka "(Name)" в св-вах листа...

- для решения обсуждаемой в теме задачи настоятельно советую использовать в коде макросов коллекцию Worksheets, а не Sheets, т.к. последняя включает в себя ещё и листы диаграмм.

Совет по небольшой оптимизации кода. Конструкцию

 With Worksheets(trgtList)
  .Cells.Select
  .Cells.EntireColumn.AutoFit
  .Cells(1, 1).Select
 End With

уместно заменить на оператор Worksheets(trgtList).Columns.AutoFit

14

Re: VBA: непустые ячейки перенести на другой лист

Dmitrii пишет:

BeS Yara, бегло посмотрел код, предложенный Вами в сообщении #12, и обнаружил в нём существенную ошибку.
Прошу не обижаться, "навожу критику" не для того, чтобы "насолить", но чтобы исправить неверное.

Для этого форум и предназначен, никаких обид

Dmitrii пишет:

Алгоритм функции GetListName() ошибочен. Она вернёт значение FALSE лишь тогда, когда имя листа не задано вообще.

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

Dmitrii пишет:

имеется противоречивый или, по крайней мере, неоднозначно понимаемый комментарий

Но в свойствах листа(в редакторе макросов) действительно есть поле "(Name)" и "Name". При этом, если судить по Locals, первому соответсвует свойство ListCodeName, а второму - CodeName и Name. С MSDN в данном вопросе не сверялся. В общем, с наименованием изначально немного напутано и моя попытка это как-то описать ясности похоже не прибавила

Dmitrii пишет:

для решения обсуждаемой в теме задачи настоятельно советую использовать в коде макросов коллекцию Worksheets, а не Sheets, т.к. последняя включает в себя ещё и листы диаграмм

Приму к сведению - с VBA сталкиваюсь не часто и часто очередной "подход" начинается с записи макроса(чтобы вспомнить как там оно делалось ). Поэтому часто использую не самые оптимальные для конкретного случая методы. К тому же в MSDN обычно хожу искать конкретные свойства, а общее описание часто просматриваю по диагонали(за что не редко потом расплачиваюсь потерянным временем). Да и найденные решения часто теряются и приходится вспоминать всё заново В общем, заведу ка я у себя в записках раздел и для VBA(давно пора).

Dmitrii пишет:

Совет по небольшой оптимизации кода.

Принято
Как раз вышеупомянутая ситуация - кусок записанного макроса доработанного кувалдой.
Более критично было когда я заполнял таблицу с использованием методов из записанного макроса(копи-паст с выбором ячеек). Потом выяснил что если поменять на чтение-запись .Value скорость копирования данных возростает раз в 20(на тестовом куске). Не говоря уже об общей производительности макроса - там уже на такую неприличную величину ускорилось, что даже была мысль задержку в цикл добавить для повышения солидности выполняемых действий в глазах пользователя

15

Re: VBA: непустые ячейки перенести на другой лист

BeS Yara пишет:

... в MSDN обычно хожу искать конкретные свойства, а общее описание часто просматриваю по диагонали...

С моей точки зрения, начинать надо не с MSDN, а со встроенной справки по VBA. Так проще и эффективнее. MSDN - это уж если информации из встроенной справки не хватило.

BeS Yara пишет:

... заведу ка я у себя в записках раздел и для VBA...

В таком случае ещё несколько советов.

1. Общие:
- без необходимости не используйте методы Activate и Select, т.к. они сильно замедляют работу макроса;
- при большом количестве операций по изменению содержимого ячеек, а особенно - по оформлению, отключайте перерисовку изображения на экране с помощью свойства ScreenUpdating объекта Application, что и ускорит работу макроса, и избавит пользователя от необходимости наблюдать процесс перерисовки.

2. По коду обсуждаемого макроса.
2.1. Определение наличия в книге листов с заданными кодовыми именами.
Фрагмент

Dim SourceListCodeName: SourceListCodeName = "Лист1"
Dim TargetListCodeName: TargetListCodeName = "Лист2"
Dim srcList, trgtList
srcList = GetListName(SourceListCodeName)
trgtList = GetListName(TargetListCodeName)
'проверяем что листы указаны верно
If IsBool(srcList) Then MsgBox "Имя листа-источника задано неправильно!", vbCritical
If IsBool(trgtList) Then MsgBox "Имя целевого листа задано неправильно!", vbCritical
If IsBool(srcList) Or IsBool(trgtList) Then Exit Sub

лучше заменить на такой

Dim objSrc As Object, objTrg As Object
On Error Resume Next
Set objSrc = Лист1
If Err.Number = 0 Then
    Set objTrg = Лист2
    If Err.Number <> 0 Then
        Err.Clear
    End If
Else
    Err.Clear
End If
On Error GoTo 0
If objSrc Is Nothing Or objTrg Is Nothing Then
    MsgBox "Кодовое имя листа-источника или (и) листа-приёмника задано неверно.", vbCritical
Else
    'MsgBox objSrc.Name & vbNewLine & objTrg.Name, vbInformation
    'Здесь должен быть код обработки данных
    '...
End If

В дальнейшем коде переменные objSrc и objTrg можно будет использовать вместо выражений Worksheets(srcList) и Worksheets(trgtList) (соответственно).
Кроме того, станут ненужными функции GetListName() и IsBool().

2.2. Определение границ исходных данных на листе.
Фрагмент

MaxRowIteration = 50 'ограничение при проходе строк
MaxColumnIteration = 100 'ограничение при проходе столбцов
Dim LastDataRow, LastDataColumn
'перебираем строки в первой колонке пока не наткнёмся на пустую.
i = FirstDataRow - 1
Do
 i = i + 1
 tmp = Sheets(srcList).Cells(i, FirstColumn).Value
Loop Until StrComp(tmp, "", vbTextCompare) = 0 Or IsNull(tmp) Or i = MaxRowIteration
LastDataRow = i - 1

лучше заменить на оператор LastDataRow = Worksheets(srcList).Range("a1").CurrentRegion.Rows.Count

Фрагмент

i = FirstColumn 'колонку дат(первая колонка диапазона) сразу пропускаем, поэтому без "-1"
Do
   i = i + 1
 If Len(Sheets(srcList).Cells(NameDataRow, i).Value) > 0 And Len(Sheets(srcList).Cells(CodeDataRow, i).Value) > 0 Then
   tmp = True
  Else
   tmp = False
 End If
Loop Until Not tmp Or i = MaxColumnIteration
LastDataColumn = i - 1

лучше заменить на оператор LastDataColumn = Worksheets(srcList).Range("a1").CurrentRegion.Columns.Count

2.3. Подсчёт среднего арифметического.
Фрагмент

tmp = 0: k = 0
For j = FirstDataRow To LastDataRow 'строка
 tmp = tmp + Sheets(srcList).Cells(j, i).Value
 k = k + 1
 Debug.Print tmp
Next
Sheets(trgtList).Cells(2, i - FirstColumn) = tmp / k

лучше заменить на такой

With Worksheets(srcList)
    Worksheets(trgtList).Cells(2, i - FirstColumn) = Application.WorksheetFunction.Average(.Range(.Cells(FirstDataRow, i), .Cells(LastDataRow, i)))
End With

16

Re: VBA: непустые ячейки перенести на другой лист

Dmitrii пишет:

С моей точки зрения, начинать надо не с MSDN, а со встроенной справки по VBA. Так проще и эффективнее. MSDN - это уж если информации из встроенной справки не хватило.

Согласен. Но её всё-таки иногда не хватает. Особенно если не могу точно сказать что ищу, ведь для правильного вопроса нужно знать большую часть ответа - в этом случае поиск по вэб позволяет постепенно сузить область поиска(вплоть до конкретной команды-метода, по которой уже можно хэлп напрячь)..Да и локально установленная MSDN с поиском в том числе по CodeZone иногда даёт больше чем встроенный хэлп

по п.2.1
Попробовал переделать под VBS(может пригодиться), но на Лист2(Set objSrc = Лист2) получаю "Недопустимый знак".
Возможно моя ошибка("заготовка" из темы WSH: преобразуем макрос VBA в скрипт VBScript), или из vbs данный финт нереализуем?


option explicit
Const xlLeft   = &HFFFFEFDD
Const xlCenter = &HFFFFEFF4

Dim objExcel
Set objExcel = WScript.CreateObject("Excel.Application")
With objExcel
 With .Workbooks.Open("c:\aScripts\vba\Копирование данных #01\post_2187101withformula.xls")
  Dim objSrc, objTrg
  On Error Resume Next
  Set objSrc = Лист2
  If Err.Number = 0 Then
    Set objTrg = Лист2
    wscript.echo "Success"
    If Err.Number <> 0 Then
        Err.Clear
    End If
   Else
    wscript.echo "Error: " & Err.Description
    Err.Clear
  End If
 On Error GoTo 0
 .Save
 .Close
 End With
 .Quit
End With
Set objExcel = Nothing
WScript.Quit 0

по п.2.2
Возможность интересная, хотя есть недостатки(чесное слово не придираюсь )...
1. Для начала нужно попасть в этот диапазон("a1") - а вдруг пользователь добавил пустую строку в начало?
2. Если вдруг в диапазоне окажется пустая строка(пользователь удалил данные а не строку), то выберется диапазон только до первой пустой строки.

Первое, наверно можно побороть защитой листа. Второе, возможно, используя UsedRange. Хотя в UsedRange могут попасть лишние данные, да и были какие-то косяки с выделением диапазона содержащего уже очищенные ячейки(если не путаю, пользовался когда-то давно для поиска первой свободной строки на листе). Хотя если честно, то реализовать проблему не смог - или проблема была "плавающая", или MS уже пропатчил. Или я тогда пользовался specialCells(xlLastCell).Row... Память дырявая, а записей не вёл

В случае перебора можно определять начало данных по некоторым признакам, а при необходимости и заходить за пустые строки (естественно с ограничением кол-ва пустых строк, чтобы не идти до конца листа). Хотя для данной задачи пожалуй с регионами и проще, и короче, и правильнее.

P.S. в любом случае - всё запишу в "органайзер", никогда не знаешь что может пригодиться Спасибо за разъяснения.

17

Re: VBA: непустые ячейки перенести на другой лист

спасибо! проблему решил, правда последние скрипты для меня уже были тяжеловаты!
но все равно спасибо за помощь!