Здравствуйте! Уважаемые знатоки Excel и VBA, если Вам не сложно помогите пожалуйста с макросом. Задача проста, но к сожалению моих скромных знаний по VBA увы недостаточно. И так что нужно сделать: Лист2. ЕСЛИ значение в ячейке DA2=6 то копировать все числовые значения из диапазона M2:CZ2 в Лист 3 начиная с ячейки С2. . ЕСЛИ значение в ячейке DA3=6 то копировать все числовые значения из диапазона M3:CZ3 в Лист 3 начиная с следующей пустой ячейки после ячейки С2 и т.д. Спасибо!
Здравствуйте! Уважаемые знатоки Excel и VBA, если Вам не сложно помогите пожалуйста с макросом. Задача проста, но к сожалению моих скромных знаний по VBA увы недостаточно. И так что нужно сделать: Лист2. ЕСЛИ значение в ячейке DA2=6 то копировать все числовые значения из диапазона M2:CZ2 в Лист 3 начиная с ячейки С2. . ЕСЛИ значение в ячейке DA3=6 то копировать все числовые значения из диапазона M3:CZ3 в Лист 3 начиная с следующей пустой ячейки после ячейки С2 и т.д. Спасибо!djon2012
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]
Как понял: [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
Здравствуйте 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
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]
Тогда попробуйте так: [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
Здравствуйте ShAM! Спасибо Вам большое за доработку макроса. У меня остались 2 последних вопроса по макросу. Я пробовал сам модифицировать его, но постоянно появляются ошибки (знаю что просто, но…блин не могу сделать). Если Вам несложно посмотрите пожалуйста. 1. Нужно ли что то изменить в макросе если число строк в Лист2 не 20 как было (выделил желтой заливкой ) а 26. 2. Как сделать чтобы после копирования числовых значений в Лист3 (это Вы сделали) удалялись пустые ячейки (в примере выделил желтой заливкой) Спасибо!!!
Здравствуйте ShAM! Спасибо Вам большое за доработку макроса. У меня остались 2 последних вопроса по макросу. Я пробовал сам модифицировать его, но постоянно появляются ошибки (знаю что просто, но…блин не могу сделать). Если Вам несложно посмотрите пожалуйста. 1. Нужно ли что то изменить в макросе если число строк в Лист2 не 20 как было (выделил желтой заливкой ) а 26. 2. Как сделать чтобы после копирования числовых значений в Лист3 (это Вы сделали) удалялись пустые ячейки (в примере выделил желтой заливкой) Спасибо!!!djon2012
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]
еще вариант, без циклов [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
Здравствуйте krosav4ig! Спасибо Вам за еще один вариант макроса. Ваш макрос отрабатывает аналогично макросу от ShAM (2 постами выше). И поэтому мои 2 вопроса по макросу остаются в силе, я продублирую их. Отправляю Вам файл с вашим вариантом макроса и моими небольшими корректировками на листах. Если Вам несложно посмотрите пожалуйста. 1. Нужно ли что то изменить в макросе если число строк в Лист2 не 20 как было (выделил желтой заливкой ) а 26. 2. Как сделать чтобы после копирования числовых значений в Лист3 (это Вы сделали) удалялись пустые ячейки (в примере выделил желтой заливкой) Спасибо!!!
Здравствуйте krosav4ig! Спасибо Вам за еще один вариант макроса. Ваш макрос отрабатывает аналогично макросу от ShAM (2 постами выше). И поэтому мои 2 вопроса по макросу остаются в силе, я продублирую их. Отправляю Вам файл с вашим вариантом макроса и моими небольшими корректировками на листах. Если Вам несложно посмотрите пожалуйста. 1. Нужно ли что то изменить в макросе если число строк в Лист2 не 20 как было (выделил желтой заливкой ) а 26. 2. Как сделать чтобы после копирования числовых значений в Лист3 (это Вы сделали) удалялись пустые ячейки (в примере выделил желтой заливкой) Спасибо!!!djon2012
Sham, огромное Вам спасибо за ответы по 2 последним вопросам. Теперь макрос отрабатывает так как мне нужно. Умная у Вас голова напичканная нужными знаниями, которые помогают вот в таких ситуациях. Спасибо!!!!!
Sham, огромное Вам спасибо за ответы по 2 последним вопросам. Теперь макрос отрабатывает так как мне нужно. Умная у Вас голова напичканная нужными знаниями, которые помогают вот в таких ситуациях. Спасибо!!!!! djon2012
Здравствуйте !!! Возникла небольшая проблема с макросом. Подскажите пожалуйста что нужно изменить в макросе чтобы при выполнении условия копировались на Лист3 значения ячеек а не формулы. Спасибо!!!
Здравствуйте !!! Возникла небольшая проблема с макросом. Подскажите пожалуйста что нужно изменить в макросе чтобы при выполнении условия копировались на Лист3 значения ячеек а не формулы. Спасибо!!!djon2012
Извините за мою тупость и куда в этом макросе я должен вставить 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
Извините за мою тупость и куда в этом макросе я должен вставить 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
Здравствуйте! При количестве строк в Лист1 около 30000 макрос работает нормально. При количестве строк где то 40000 и больше макрос выдает ошибку Run-time error 13 type mismatch в строке макроса If Cells(w, 105) = 6 Then. В чем проблема обьясните пожалуйста. Спасибо!
Здравствуйте! При количестве строк в Лист1 около 30000 макрос работает нормально. При количестве строк где то 40000 и больше макрос выдает ошибку Run-time error 13 type mismatch в строке макроса If Cells(w, 105) = 6 Then. В чем проблема обьясните пожалуйста. Спасибо!djon2012