Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1
RSS
Копирование в разные листы с разными критериями
 
#1
31.05.2018 07:59:38
Доброго времени суток!
Подскажите как можно копировать из одного листа в другой по слову определителю?Например движок в лист движка, насос в лист насоса.Пример прилагается.
 
 
 
#2
31.05.2018 08:10:07
листы будут называться аналогично слову определителю?
 
 
 
#3
31.05.2018 08:10:51
VideoAlex, Да
 
 
 
#4
31.05.2018 08:19:50
Код
Sub qwe()
jlastrow = Sheets(1).Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To Sheets.Count
ilastrow = Sheets(i).Cells(Rows.Count, 1).End(xlUp).Row
Name = Sheets(i).Name
For j = 1 To jlastrow
If Sheets(1).Cells(j, 1).Value = Name Then
    Sheets(i).Cells(ilastrow, 1).Value = Sheets(1).Cells(j, 1).Value
    ilastrow = ilastrow + 1
End If
Next j
Next i
End Sub
 
 
 
#5
31.05.2018 08:27:26
VideoAlex, Спасибо!А Ещё подскажите а можно макрос сделать чтобы от отыскивал именно слова и переносил по листам?Слова в последствии будут добавляться и листы соответственно
 
 
 
#6
31.05.2018 08:30:53
где отыскивал? всё что в первом столбце это слово определитель? если нет листа то добавить?
 
 
 
#7
31.05.2018 08:38:27
VideoAlex, не совсем так.Если в первом столбце есть слово определитель копировать всю строку(Там может стоять не только слово но и его описание) в лист с названием слова определителя.
 
 
 
#8
31.05.2018 08:53:01
скажите внятно - в первом столбце будет только слово-определитель или фраза с этим словом
движок или движок ассинхронный туева хуча оборотов 380 вольт напряжение стопитсот киловат
и если нет листа то чтото делать или не делать ничего?
Изменено: VideoAlex - 31.05.2018 08:53:50
 
 
 
#9
31.05.2018 08:59:53
VideoAlex, В первом столбце его номер, во втором движок ассинхронный туева хуча оборотов 380 вольт напряжение стопитсот киловат, и если листа нет вывести меседж нет данных
 
 
 
#10
31.05.2018 10:19:43
Код
Sub qwe()
jlastrow = Sheets(1).Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To Sheets.Count
ilastrow = Sheets(i).Cells(Rows.Count, 1).End(xlUp).Row
If Sheets(i).Cells(1, 1).Value = "" Then ilastrow = 0
Name = Sheets(i).Name
For j = 1 To jlastrow
If InStr(1, Sheets(1).Cells(j, 2).Value, Name) <> 0 Then Sheets(1).Cells(j, 2).Copy Sheets(i).Cells(ilastrow + 1, 1): ilastrow = ilastrow + 1
Next j
Next i
End Sub
Изменено: VideoAlex - 31.05.2018 10:33:17
 
 
 
#11
31.05.2018 10:33:33
изменил. там косячок был
 
 
 
#12
31.05.2018 11:03:26
VideoAlex, Как-то не коректно  работает
 
 
 
#13
31.05.2018 12:46:43
VideoAlex, Сорян!Всё работает!!Большое спасибо!!
 
 
 
#14
31.05.2018 13:25:39
макрос ищет последнюю строку по первому столбцу - вы обещали там номера. плюс у вас ошибка есть как минимум одна - лист protektor, а в ячейке protector

вот еще вариант
Код
Sub qw()
Dim rn As Range
Dim rng As Range
jlastrow = Sheets(1).Cells(Rows.Count, 2).End(xlUp).Row
For i = 2 To Sheets.Count
ilastrow = Sheets(i).Cells(Rows.Count, 1).End(xlUp).Row
If Sheets(i).Cells(1, 1).Value = "" Then ilastrow = 0
Name = Sheets(i).Name
For j = 1 To jlastrow
If InStr(1, Sheets(1).Cells(j, 2).Value, Name) <> 0 Then
    If rn Is Nothing Then Set rn = Sheets(1).Cells(j, 2) Else Set rn = Union(rn, Sheets(1).Cells(j, 2))
End If
Next j
If Not rn Is Nothing Then rn.Copy Sheets(i).Cells(ilastrow + 1, 1)
Set rn = Nothing
Next i
End Sub
Изменено: VideoAlex - 31.05.2018 13:57:19
 
 
 
#15
01.06.2018 12:20:14
VideoAlex, Спасибо за ошибку.Оно работает и так.Столкнулся с проблемой.Закинул данные по листамбразбил их через разделитель(Касается листа мотор)Перевёл  всё согласно требованиям заказчика. Теперь не знаю как написать чтобы программа по соответствию копировала в первый лист серию по требованию заказчика.Т.е V1 лист мотор копировался в табличку листа 1 где стоит слово мотор
 
 
 
#16
24.06.2018 20:44:34
VideoAlex, Доброго времени суток!Столкнулся с проблемой.Листы называются AGH, GS и AGH  он закидывает в оба.Не подскажите как решить?
 
 
 
#17
24.06.2018 22:11:42
Цитата
Листы называются AGH, GS и AGH
В каком примере эти листы?
В примере Test2.xlsm листы PUMP, MOTOR, PROTEKTOR
Почему на листе Sheet1 в строке 11 после MOTOR стоит запятая, хотя во всех остальных двоеточие?
 
 
 
#18
25.06.2018 05:55:57
Kuzmich, Сообщение #5. Вам конкретный пример с AGH, GS и AGH  нужен? А в остальном да там и запятая и тире и двоеточие попадается. Описания в последствии отыскиваются и приводятся в соответствие
 
 
 
#19
25.06.2018 06:58:21
В лист AGH, GS заидывает правильно.А в лист AGH  закидывает и AGH, GS и AGH.
Код
Sub qwe()
jlastrow = Sheets(1).Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To Sheets.Count
ilastrow = Sheets(i).Cells(Rows.Count, 1).End(xlUp).Row
If Sheets(i).Cells(1, 1).Value = "" Then ilastrow = 0
Name = Sheets(i).Name
For j = 1 To jlastrow
If InStr(1, Sheets(1).Cells(j, 2).Value, Name) <> 0 Then Sheets(1).Cells(j, 2).Copy Sheets(i).Cells(ilastrow + 1, 1): ilastrow = ilastrow + 1
Next j
Next i
End Sub


 
Изменено: foxster_72 - 25.06.2018 06:58:44
 
 
 
#20
25.06.2018 07:24:10
Всё просто. в листе с названием "AGH, GS" содержится название листа "AGH" в первоначальном примере этого небыло и теперь всё надо переделать
есть вариант автозаменой переименовать все AGH, GS в халигалипаратрупер, переименовать так же лист AGH, GS отработать макросом и переименовать назад всё
Изменено: VideoAlex - 25.06.2018 07:27:30
 
 
 
#21
25.06.2018 09:21:29
Цитата
там и запятая и тире и двоеточие попадается.
В примере Test2.xlsm вставьте на листе ' Sheet1' первую строку - шапку и в В1 какое-либо название
Затем запустите макрос из стандартного модуля
Код
Sub RaznestiDannye()
Dim i As Long
Dim n As Long
Dim iLastRow As Long
Dim Criterij As String
Dim iName As String
Dim Sht As Worksheet
Application.ScreenUpdating = False
  Set Sht = ThisWorkbook.Worksheets("Sheet1")
    iLastRow = Sht.Cells(Rows.Count, "B").End(xlUp).Row
    Range("C1:D" & iLastRow).ClearContents
   With CreateObject("VBScript.RegExp")
       .Global = True
       .IgnoreCase = True
       .Pattern = "^[A-Z]+(?=:|,|-)"
     For i = 2 To iLastRow
       Cells(i, "C") = .Execute(Cells(i, "B"))(0)
     Next
   End With
       Range("C1") = Range("B1")
     'отбор уникальных значений столбца C в столбец D
    Range("C1:C" & Cells(Rows.Count, "C").End(xlUp).Row).AdvancedFilter Action:=xlFilterCopy _
                                  , CopyToRange:=Range("D1"), Unique:=True
     'количество уникальных значений
      n = Cells(Rows.Count, "D").End(xlUp).Row
    For i = 2 To n          'цикл по уникальным значениям
        Criterij = Sht.Cells(i, "D")
        iName = Criterij    'имя нового листа
     If Not SheetExist(iName) Then  'функция проверки наличия листа в файле
       'создаем новый лист
       Worksheets.Add After:=Worksheets(Worksheets.Count)
         ActiveSheet.Name = iName
     Else
       Worksheets(iName).Activate
       Cells.Clear
     End If
       'ставим автофильтр по столбцу C
         Sht.Range("B1:C20").AutoFilter 2, Criterij
       'копируем видимые строки в новый лист
        Sht.AutoFilter.Range.SpecialCells(xlCellTypeVisible).Copy
        With Worksheets(iName)
          .Range("B1").PasteSpecial xlPasteColumnWidths
          .Range("B1").PasteSpecial xlPasteFormats
          .Range("B1").PasteSpecial xlPasteValues
             Sht.AutoFilter.Range.AutoFilter
          .Columns("C").Delete
          .Range("B1").Select
        End With
    Next
Application.ScreenUpdating = True
End Sub
 
     'функция проверки наличия листа в файле, лист есть - true
Function SheetExist(iName As String) As Boolean
    On Error Resume Next
    With Worksheets(iName): End With
    SheetExist = (Err = 0)
End Function
 
 
 
#22
25.06.2018 09:40:20
:)
Цитата
foxster_72 написал:  VideoAlex , Спасибо за ошибку
 
 
 
#23
27.06.2018 07:30:32
Kuzmich, думаю это не совсем то что нужно. Давайте для ясности я обрисую масштаб проблемы. Имеется текс с описанием в листе GeMs.Под каждый текс тыделен лист соответствующий первому слову.Мне нужно чтобы макрос закинул их по слову определителю в листы. В листах ведётся анализ текста(описания), по описанию выстраивается запись наподобии  шифра. И перекидывается обратно в лист GeMs в C1. Можно ли сделать просто чтобы макрос искал в строке слово,и если находил перекидывал в лист всю строку?
 
 
 
#24
27.06.2018 11:28:40
Цитата
В листах ведётся анализ текста(описания), по описанию выстраивается запись наподобии  шифра
А что мешает проводит этот анализ в листе GeMS ? Текст в каждой ячейке столбца А разбиваете на части по разделителю - запятая
и переносите в ячейки, начиная со столбца В (Текст по столбцам). Затем уже в этих ячейках проводите свой анализ.
Цитата
И перекидывается обратно в лист GeMs в C1
Вы бы в примере показали, что переносится в С1
 
 
 
#25
27.06.2018 11:50:23
Kuzmich, Чтобы проще было объеснять на примере мотора покажу.Как видно из листа мотор, Всё описание раскинуто через разделитель. Если с цифами всё понятно, текс меняется к примеру (1PEDMT, 2PEDMT 3,4,5,61,62,7,8,9,(1,2,3.......9)VPEDMT, (1,2,3.......9)NPEDMT ) и всё тоже самое c HT. С остальными ячейками приблизительно тоже самое, и остальными листами тоже. Там добавляются табличные данные и расчёт. После этого  в подсвеченные синим ячейки сводится всё что получили и отправляется в лист GeMS. Поэтому ниего лучше не придумал как раскидать по листам и там уже писать условия для анализа.
 
 
 
#26
27.06.2018 14:52:12
foxster_72, написал
Цитата
Поэтому ниего лучше не придумал как раскидать по листам и там уже писать условия для анализа.
А я предлагаю раскидать прямо в листе GeMS, делать свой анализ и затем удалить лишние столбцы
Вот так можно раскидать текст из столбца В
Код
Sub RaznestiDannye()
Dim i As Long
Dim n As Long
Dim iLastRow As Long
Application.ScreenUpdating = False
    iLastRow = Cells(Rows.Count, "B").End(xlUp).Row
    Range("C1:R" & iLastRow).ClearContents      'очищаем диапазон до формул
   With CreateObject("VBScript.RegExp")
       .Global = True
       .IgnoreCase = True
       .Pattern = "^[A-Z]+(?=:|,|-)"
     For i = 1 To iLastRow
       Cells(i, "C") = Mid(.Replace(Cells(i, "B"), ""), 2)
     Next
   End With
   Range("C1:C" & iLastRow).TextToColumns Destination:=Range("C1"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
        Semicolon:=False, Comma:=True, Space:=False, Other:=False, FieldInfo _
        :=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1), Array(6, 1), _
        Array(7, 1), Array(8, 1), Array(9, 1), Array(10, 1), Array(11, 1), Array(12, 1), Array(13, 1 _
        ), Array(14, 1), Array(15, 1)), TrailingMinusNumbers:=True
Application.ScreenUpdating = True
End Sub
И не нужно переносить данные в листы, а затем нужную информацию обратно на лист GeMS
 
 
 
#27
28.06.2018 11:01:08
Kuzmich, попробовал сделать на одном листе по вашей методе. Получается что весь анализ нужно перелапачивать. Но всё равно спасибо вам большое, этот макрос будет работать в соседнем отделе!!!Я нашёл выход иначе только не знаю как сделать чтобы не было всплывающих окон, а непоредственно сразу макрос искал то что нужно.
Код
Sub Del_SubStr()
    Dim sSubStr As String 'искомое слово или фраза(может быть указанием на ячейку)
    Dim lCol As Long 'номер столбца с просматриваемыми значениями
    Dim lLastRow As Long, li As Long
    Dim lMet As Long
    Dim arr
 
    sSubStr = InputBox("Укажите значение, которое необходимо найти в строке", "Запрос параметра", "")
    If sSubStr = "" Then lMet = 0 Else lMet = 1
    lCol = Val(InputBox("Укажите номер столбца, в котором искать указанное значение", "Запрос параметра", 1))
    If lCol = 0 Then Exit Sub
 
    lLastRow = ActiveSheet.UsedRange.Row - 1 + ActiveSheet.UsedRange.Rows.Count
    arr = Cells(1, lCol).Resize(lLastRow).Value
    Application.ScreenUpdating = 0
    Dim rr As Range
    For li = 1 To lLastRow
        If -(InStr(arr(li, 1), sSubStr) > 0) = lMet Then
            If rr Is Nothing Then
                Set rr = Cells(li, 1)
            Else
                Set rr = Union(rr, Cells(li, 1))
            End If
        End If
    Next li
    If Not rr Is Nothing Then rr.EntireRow.Delete
    Application.ScreenUpdating = 1
End Sub
 
 
 
Страницы: 1
Наверх