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

Вход

Регистрация

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

 

= Мир MS Excel/Копирование только числовых значений при условии. - Мир MS Excel

Старая форма входа
  • Страница 1 из 1
  • 1
Модератор форума: китин, _Boroda_  
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Копирование только числовых значений при условии. (Макросы/Sub)
Копирование только числовых значений при условии.
djon2012 Дата: Суббота, 10.01.2015, 01:22 | Сообщение № 1
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 106
Репутация: 0 ±
Замечаний: 0% ±

Excel 2010
Здравствуйте! Уважаемые знатоки Excel и VBA, если Вам не сложно помогите пожалуйста с макросом. Задача проста, но к сожалению моих скромных знаний по VBA увы недостаточно.
И так что нужно сделать:
Лист2. ЕСЛИ значение в ячейке DA2=6 то копировать все числовые значения из диапазона M2:CZ2 в Лист 3 начиная с ячейки С2. . ЕСЛИ значение в ячейке DA3=6 то копировать все числовые значения из диапазона M3:CZ3 в Лист 3 начиная с следующей пустой ячейки после ячейки С2 и т.д.
Спасибо!
К сообщению приложен файл: 7574802.xlsb (21.6 Kb)
 
Ответить
СообщениеЗдравствуйте! Уважаемые знатоки Excel и VBA, если Вам не сложно помогите пожалуйста с макросом. Задача проста, но к сожалению моих скромных знаний по VBA увы недостаточно.
И так что нужно сделать:
Лист2. ЕСЛИ значение в ячейке DA2=6 то копировать все числовые значения из диапазона M2:CZ2 в Лист 3 начиная с ячейки С2. . ЕСЛИ значение в ячейке DA3=6 то копировать все числовые значения из диапазона M3:CZ3 в Лист 3 начиная с следующей пустой ячейки после ячейки С2 и т.д.
Спасибо!

Автор - djon2012
Дата добавления - 10.01.2015 в 01:22
ShAM Дата: Суббота, 10.01.2015, 06:14 | Сообщение № 2
Группа: Друзья
Ранг: Старожил
Сообщений: 1347
Репутация: 249 ±
Замечаний: 0% ±

Excel 2010
Как понял:
[vba]
Код
Sub djon2012()
Dim rng As Range, LastRow%, i%
Sheets("Лист3").[c3:cp10000].ClearContents
LastRow = Cells(Rows.Count, 105).End(xlUp).Row
     For i = 2 To LastRow
         If Cells(i, 105) = 6 Then
            If rng Is Nothing Then
               Set rng = Range("M" & i & ":CZ" & i)
            Else
               Set rng = Application.Union(rng, Range("m" & i & ":CZ" & i))
            End If
         End If
     Next
If Not (rng Is Nothing) Then rng.Copy Sheets("Лист3").[c3]
End Sub
[/vba]
К сообщению приложен файл: djon2012.xlsb (23.5 Kb)
 
Ответить
СообщениеКак понял:
[vba]
Код
Sub djon2012()
Dim rng As Range, LastRow%, i%
Sheets("Лист3").[c3:cp10000].ClearContents
LastRow = Cells(Rows.Count, 105).End(xlUp).Row
     For i = 2 To LastRow
         If Cells(i, 105) = 6 Then
            If rng Is Nothing Then
               Set rng = Range("M" & i & ":CZ" & i)
            Else
               Set rng = Application.Union(rng, Range("m" & i & ":CZ" & i))
            End If
         End If
     Next
If Not (rng Is Nothing) Then rng.Copy Sheets("Лист3").[c3]
End Sub
[/vba]

Автор - ShAM
Дата добавления - 10.01.2015 в 06:14
djon2012 Дата: Суббота, 10.01.2015, 10:30 | Сообщение № 3
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 106
Репутация: 0 ±
Замечаний: 0% ±

Excel 2010
Здравствуйте ShAM! Большое Вам спасибо за помощь. Макрос работает почти так как нужно но есть нюансы, наверное я плохо обьяснил, извиняюсь.
1. Rem Sheets("Лист3").[c3:cp10000].ClearContents очищать не надо.
2. Слово ЛОЖЬ выводить не надо, это логическое значение а мне надо только числовые.
3. И последнее почему не нужно очищать данные по пункту 1. Мне нужно чтобы при каждом последующем запуске макроса (а их будет много) данные на Лист3 не очищались а выводились в следующюю пустую строку в данном примере это 7 строка и т.д. Данные на Лист3 O2:CZ21 будут постоянно изменяться и число строк удовлетворяющих условию также постоянно будут изменяться.
Спасибо!!!
 
Ответить
СообщениеЗдравствуйте ShAM! Большое Вам спасибо за помощь. Макрос работает почти так как нужно но есть нюансы, наверное я плохо обьяснил, извиняюсь.
1. Rem Sheets("Лист3").[c3:cp10000].ClearContents очищать не надо.
2. Слово ЛОЖЬ выводить не надо, это логическое значение а мне надо только числовые.
3. И последнее почему не нужно очищать данные по пункту 1. Мне нужно чтобы при каждом последующем запуске макроса (а их будет много) данные на Лист3 не очищались а выводились в следующюю пустую строку в данном примере это 7 строка и т.д. Данные на Лист3 O2:CZ21 будут постоянно изменяться и число строк удовлетворяющих условию также постоянно будут изменяться.
Спасибо!!!

Автор - djon2012
Дата добавления - 10.01.2015 в 10:30
ShAM Дата: Суббота, 10.01.2015, 12:48 | Сообщение № 4
Группа: Друзья
Ранг: Старожил
Сообщений: 1347
Репутация: 249 ±
Замечаний: 0% ±

Excel 2010
Тогда попробуйте так:
[vba]
Код
Sub djon2012()
Dim rng As Range, LastRow1%, LastRow2%, i%
With Sheets("Лист3")
LastRow1 = Cells(Rows.Count, 105).End(xlUp).Row
LastRow2 = .Cells(Rows.Count, 3).End(xlUp).Row + 1
If LastRow2 = 2 Then LastRow2 = 3
     For i = 2 To LastRow1
         If Cells(i, 105) = 6 Then
            If rng Is Nothing Then
               Set rng = Range("M" & i & ":CZ" & i)
            Else
               Set rng = Application.Union(rng, Range("M" & i & ":CZ" & i))
            End If
         End If
     Next
If Not (rng Is Nothing) Then rng.Copy .Cells(LastRow2, 3)
.Range("C" & LastRow2 & ":CP" & LastRow2 + 20).Replace What:="FALSE", Replacement:=""
End With
End Sub
[/vba]
К сообщению приложен файл: djon2012_1.xlsb (24.0 Kb)
 
Ответить
СообщениеТогда попробуйте так:
[vba]
Код
Sub djon2012()
Dim rng As Range, LastRow1%, LastRow2%, i%
With Sheets("Лист3")
LastRow1 = Cells(Rows.Count, 105).End(xlUp).Row
LastRow2 = .Cells(Rows.Count, 3).End(xlUp).Row + 1
If LastRow2 = 2 Then LastRow2 = 3
     For i = 2 To LastRow1
         If Cells(i, 105) = 6 Then
            If rng Is Nothing Then
               Set rng = Range("M" & i & ":CZ" & i)
            Else
               Set rng = Application.Union(rng, Range("M" & i & ":CZ" & i))
            End If
         End If
     Next
If Not (rng Is Nothing) Then rng.Copy .Cells(LastRow2, 3)
.Range("C" & LastRow2 & ":CP" & LastRow2 + 20).Replace What:="FALSE", Replacement:=""
End With
End Sub
[/vba]

Автор - ShAM
Дата добавления - 10.01.2015 в 12:48
djon2012 Дата: Воскресенье, 11.01.2015, 00:51 | Сообщение № 5
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 106
Репутация: 0 ±
Замечаний: 0% ±

Excel 2010
Здравствуйте ShAM! Спасибо Вам большое за доработку макроса. У меня остались 2 последних вопроса по макросу. Я пробовал сам модифицировать его, но постоянно появляются ошибки (знаю что просто, но…блин не могу сделать). Если Вам несложно посмотрите пожалуйста.
1. Нужно ли что то изменить в макросе если число строк в Лист2 не 20 как было (выделил желтой заливкой ) а 26.
2. Как сделать чтобы после копирования числовых значений в Лист3 (это Вы сделали) удалялись пустые ячейки (в примере выделил желтой заливкой)
Спасибо!!!
К сообщению приложен файл: 2683581.xlsb (25.5 Kb)
 
Ответить
СообщениеЗдравствуйте ShAM! Спасибо Вам большое за доработку макроса. У меня остались 2 последних вопроса по макросу. Я пробовал сам модифицировать его, но постоянно появляются ошибки (знаю что просто, но…блин не могу сделать). Если Вам несложно посмотрите пожалуйста.
1. Нужно ли что то изменить в макросе если число строк в Лист2 не 20 как было (выделил желтой заливкой ) а 26.
2. Как сделать чтобы после копирования числовых значений в Лист3 (это Вы сделали) удалялись пустые ячейки (в примере выделил желтой заливкой)
Спасибо!!!

Автор - djon2012
Дата добавления - 11.01.2015 в 00:51
krosav4ig Дата: Воскресенье, 11.01.2015, 00:57 | Сообщение № 6
Группа: Друзья
Ранг: Старожил
Сообщений: 2346
Репутация: 989 ±
Замечаний: 0% ±

Excel 2007,2010,2013
еще вариант, без циклов
[vba]
Код
Sub djon2012()
     Dim SH1 As Worksheet, SH2 As Worksheet, rng As Range
     Set SH1 = ThisWorkbook.Sheets("Лист2")
     Set SH2 = ThisWorkbook.Sheets("Лист3")
     Application.ScreenUpdating = 0
     Do: With SH1.[DA:DA].SpecialCells(xlCellTypeFormulas, 1).Offset(, 1)
         .FormulaR1C1 = "=IF(RC[-1]=6,RC[-1])": On Error Resume Next
         Set rng = .SpecialCells(xlCellTypeFormulas, 1)
         If rng Is Nothing Then .ClearContents: Exit Do Else: Intersect(SH1.[M:CZ], rng.EntireRow).Copy
         SH2.[C2].Offset(Application.CountA(SH2.[C:C])).PasteSpecial Paste:=xlPasteAll, Operation:=2
         .ClearContents: Sheets.Select: SH1.[A1].Select: SH1.Select:
     End With: Loop Until True
     Application.ScreenUpdating = 1
End Sub
[/vba]
К сообщению приложен файл: 3661328.xlsb (20.8 Kb)


email:krosav4ig26@gmail.com WMR R207627035142 WMZ Z821145374535 ЯД 410012026478460
 
Ответить
Сообщениееще вариант, без циклов
[vba]
Код
Sub djon2012()
     Dim SH1 As Worksheet, SH2 As Worksheet, rng As Range
     Set SH1 = ThisWorkbook.Sheets("Лист2")
     Set SH2 = ThisWorkbook.Sheets("Лист3")
     Application.ScreenUpdating = 0
     Do: With SH1.[DA:DA].SpecialCells(xlCellTypeFormulas, 1).Offset(, 1)
         .FormulaR1C1 = "=IF(RC[-1]=6,RC[-1])": On Error Resume Next
         Set rng = .SpecialCells(xlCellTypeFormulas, 1)
         If rng Is Nothing Then .ClearContents: Exit Do Else: Intersect(SH1.[M:CZ], rng.EntireRow).Copy
         SH2.[C2].Offset(Application.CountA(SH2.[C:C])).PasteSpecial Paste:=xlPasteAll, Operation:=2
         .ClearContents: Sheets.Select: SH1.[A1].Select: SH1.Select:
     End With: Loop Until True
     Application.ScreenUpdating = 1
End Sub
[/vba]

Автор - krosav4ig
Дата добавления - 11.01.2015 в 00:57
djon2012 Дата: Воскресенье, 11.01.2015, 10:26 | Сообщение № 7
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 106
Репутация: 0 ±
Замечаний: 0% ±

Excel 2010
Здравствуйте krosav4ig! Спасибо Вам за еще один вариант макроса. Ваш макрос отрабатывает аналогично макросу от ShAM (2 постами выше). И поэтому мои 2 вопроса по макросу остаются в силе, я продублирую их. Отправляю Вам файл с вашим вариантом макроса и моими небольшими корректировками на листах. Если Вам несложно посмотрите пожалуйста.
1. Нужно ли что то изменить в макросе если число строк в Лист2 не 20 как было (выделил желтой заливкой ) а 26.
2. Как сделать чтобы после копирования числовых значений в Лист3 (это Вы сделали) удалялись пустые ячейки (в примере выделил желтой заливкой)
Спасибо!!!
К сообщению приложен файл: 7641067.xlsb (21.4 Kb)
 
Ответить
СообщениеЗдравствуйте krosav4ig! Спасибо Вам за еще один вариант макроса. Ваш макрос отрабатывает аналогично макросу от ShAM (2 постами выше). И поэтому мои 2 вопроса по макросу остаются в силе, я продублирую их. Отправляю Вам файл с вашим вариантом макроса и моими небольшими корректировками на листах. Если Вам несложно посмотрите пожалуйста.
1. Нужно ли что то изменить в макросе если число строк в Лист2 не 20 как было (выделил желтой заливкой ) а 26.
2. Как сделать чтобы после копирования числовых значений в Лист3 (это Вы сделали) удалялись пустые ячейки (в примере выделил желтой заливкой)
Спасибо!!!

Автор - djon2012
Дата добавления - 11.01.2015 в 10:26
ShAM Дата: Воскресенье, 11.01.2015, 19:53 | Сообщение № 8
Группа: Друзья
Ранг: Старожил
Сообщений: 1347
Репутация: 249 ±
Замечаний: 0% ±

Excel 2010
1. Нужно ли что то изменить в макросе если число строк в Лист2 не 20 как было (выделил желтой заливкой ) а 26.
Эту строку: [vba]
Код
.Range("C" & LastRow2 & ":CP" & LastRow2 + 20).Replace What:="FALSE", Replacement:=""
[/vba]поменять на [vba]
Код
.Range("C" & LastRow2 & ":CP" & LastRow2 + LastRow1 - 1).Replace What:="FALSE", Replacement:=""
[/vba]Число строк может быть любое.
По 2-му вопросу Вы, вроде, создали новую тему. Но т.к. появился 2-й вопрос, то, ИМХО, и макрос другой нужен.
 
Ответить
Сообщение
1. Нужно ли что то изменить в макросе если число строк в Лист2 не 20 как было (выделил желтой заливкой ) а 26.
Эту строку: [vba]
Код
.Range("C" & LastRow2 & ":CP" & LastRow2 + 20).Replace What:="FALSE", Replacement:=""
[/vba]поменять на [vba]
Код
.Range("C" & LastRow2 & ":CP" & LastRow2 + LastRow1 - 1).Replace What:="FALSE", Replacement:=""
[/vba]Число строк может быть любое.
По 2-му вопросу Вы, вроде, создали новую тему. Но т.к. появился 2-й вопрос, то, ИМХО, и макрос другой нужен.

Автор - ShAM
Дата добавления - 11.01.2015 в 19:53
djon2012 Дата: Понедельник, 12.01.2015, 01:11 | Сообщение № 9
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 106
Репутация: 0 ±
Замечаний: 0% ±

Excel 2010
Sham, огромное Вам спасибо за ответы по 2 последним вопросам. Теперь макрос отрабатывает так как мне нужно. Умная у Вас голова напичканная нужными знаниями, которые помогают вот в таких ситуациях. Спасибо!!!!! hands hands hands hands hands hands hands hands hands hands hands
 
Ответить
СообщениеSham, огромное Вам спасибо за ответы по 2 последним вопросам. Теперь макрос отрабатывает так как мне нужно. Умная у Вас голова напичканная нужными знаниями, которые помогают вот в таких ситуациях. Спасибо!!!!! hands hands hands hands hands hands hands hands hands hands hands

Автор - djon2012
Дата добавления - 12.01.2015 в 01:11
djon2012 Дата: Суббота, 17.01.2015, 14:40 | Сообщение № 10
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 106
Репутация: 0 ±
Замечаний: 0% ±

Excel 2010
Здравствуйте !!!
Возникла небольшая проблема с макросом. Подскажите пожалуйста что нужно изменить в макросе чтобы при выполнении условия копировались на Лист3 значения ячеек а не формулы.
Спасибо!!!
К сообщению приложен файл: 123.xlsb (32.2 Kb)


Сообщение отредактировал djon2012 - Суббота, 17.01.2015, 16:05
 
Ответить
СообщениеЗдравствуйте !!!
Возникла небольшая проблема с макросом. Подскажите пожалуйста что нужно изменить в макросе чтобы при выполнении условия копировались на Лист3 значения ячеек а не формулы.
Спасибо!!!

Автор - djon2012
Дата добавления - 17.01.2015 в 14:40
RAN Дата: Суббота, 17.01.2015, 17:11 | Сообщение № 11
Группа: Друзья
Ранг: Экселист
Сообщений: 5660
Репутация: 1163 ±
Замечаний: 0% ±

2010
[vba]
Код
xlPasteAll
[/vba]


Быть или не быть, вот в чем загвоздка!
 
Ответить
Сообщение[vba]
Код
xlPasteAll
[/vba]

Автор - RAN
Дата добавления - 17.01.2015 в 17:11
djon2012 Дата: Суббота, 17.01.2015, 18:55 | Сообщение № 12
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 106
Репутация: 0 ±
Замечаний: 0% ±

Excel 2010

Извините за мою тупость и куда в этом макросе я должен вставить xlPasteAll.
[vba]
Код
Sub qqq()
Dim rng As Range, LastRow1%, LastRow2%, i%
With Sheets("Лист3")
LastRow1 = Cells(Rows.Count, 105).End(xlUp).Row
LastRow2 = .Cells(Rows.Count, 3).End(xlUp).Row + 1
If LastRow2 = 2 Then LastRow2 = 3
For i = 2 To LastRow1
If Cells(i, 105) = 84 Then
If rng Is Nothing Then
Set rng = Range("M" & i & ":CZ" & i)
Else
Set rng = Application.Union(rng, Range("M" & i & ":CZ" & i))
End If
End If
Next
If Not (rng Is Nothing) Then rng.Copy .Cells(LastRow2, 3)
Rem .Range("C" & LastRow2 & ":CP" & LastRow2 + LastRow1 - 1).Replace What:="FALSE", Replacement:=""
Rem .Range("E" & LastRow2 & ":CP" & LastRow2 + LastRow1 - 1).SpecialCells(xlCellTypeBlanks).Delete Shift:=xlToLeft
.Range("C" & LastRow2 & ":CP" & LastRow2 + LastRow1 - 1).SpecialCells(xlCellTypeConstants, 4).Delete Shift:=xlToLeft
End With
End Sub
[/vba]
 
Ответить
Сообщение
Извините за мою тупость и куда в этом макросе я должен вставить xlPasteAll.
[vba]
Код
Sub qqq()
Dim rng As Range, LastRow1%, LastRow2%, i%
With Sheets("Лист3")
LastRow1 = Cells(Rows.Count, 105).End(xlUp).Row
LastRow2 = .Cells(Rows.Count, 3).End(xlUp).Row + 1
If LastRow2 = 2 Then LastRow2 = 3
For i = 2 To LastRow1
If Cells(i, 105) = 84 Then
If rng Is Nothing Then
Set rng = Range("M" & i & ":CZ" & i)
Else
Set rng = Application.Union(rng, Range("M" & i & ":CZ" & i))
End If
End If
Next
If Not (rng Is Nothing) Then rng.Copy .Cells(LastRow2, 3)
Rem .Range("C" & LastRow2 & ":CP" & LastRow2 + LastRow1 - 1).Replace What:="FALSE", Replacement:=""
Rem .Range("E" & LastRow2 & ":CP" & LastRow2 + LastRow1 - 1).SpecialCells(xlCellTypeBlanks).Delete Shift:=xlToLeft
.Range("C" & LastRow2 & ":CP" & LastRow2 + LastRow1 - 1).SpecialCells(xlCellTypeConstants, 4).Delete Shift:=xlToLeft
End With
End Sub
[/vba]

Автор - djon2012
Дата добавления - 17.01.2015 в 18:55
RAN Дата: Суббота, 17.01.2015, 19:04 | Сообщение № 13
Группа: Друзья
Ранг: Экселист
Сообщений: 5660
Репутация: 1163 ±
Замечаний: 0% ±

2010
Я про тот макрос, что в теме виден.
В конструкции
[vba]
Код
rng.Copy .Cells(LastRow2, 3)
[/vba]
никак.
Нужно
[vba]
Код
rng.Copy
.Cells(LastRow2, 3).PasteSpecial Paste:=xlPasteValues
[/vba]


Быть или не быть, вот в чем загвоздка!
 
Ответить
СообщениеЯ про тот макрос, что в теме виден.
В конструкции
[vba]
Код
rng.Copy .Cells(LastRow2, 3)
[/vba]
никак.
Нужно
[vba]
Код
rng.Copy
.Cells(LastRow2, 3).PasteSpecial Paste:=xlPasteValues
[/vba]

Автор - RAN
Дата добавления - 17.01.2015 в 19:04
djon2012 Дата: Суббота, 17.01.2015, 19:35 | Сообщение № 14
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 106
Репутация: 0 ±
Замечаний: 0% ±

Excel 2010
Спасибо RAN!!! Урррааа, Заработалооооооооо! hands hands hands hands hands hands hands hands hands
 
Ответить
СообщениеСпасибо RAN!!! Урррааа, Заработалооооооооо! hands hands hands hands hands hands hands hands hands

Автор - djon2012
Дата добавления - 17.01.2015 в 19:35
djon2012 Дата: Суббота, 22.04.2017, 18:30 | Сообщение № 15
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 106
Репутация: 0 ±
Замечаний: 0% ±

Excel 2010
Здравствуйте!
При количестве строк в Лист1 около 30000 макрос работает нормально. При количестве строк где то 40000 и больше макрос выдает ошибку Run-time error 13 type mismatch в строке макроса If Cells(w, 105) = 6 Then. В чем проблема обьясните пожалуйста. Спасибо!
К сообщению приложен файл: 5138437.xlsb (76.7 Kb)


Сообщение отредактировал djon2012 - Воскресенье, 23.04.2017, 08:02
 
Ответить
СообщениеЗдравствуйте!
При количестве строк в Лист1 около 30000 макрос работает нормально. При количестве строк где то 40000 и больше макрос выдает ошибку Run-time error 13 type mismatch в строке макроса If Cells(w, 105) = 6 Then. В чем проблема обьясните пожалуйста. Спасибо!

Автор - djon2012
Дата добавления - 22.04.2017 в 18:30
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Копирование только числовых значений при условии. (Макросы/Sub)
  • Страница 1 из 1
  • 1
Поиск:

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