Прескочи на основното съдържание

Как да копирате редове от множество работни листове въз основа на критерии в нов лист?

Автор: Xiaoyang Последна промяна: 2019-09-10

Да предположим, че имате работна книга с три работни листа, които имат същото форматиране като показаното по-долу екранно изображение. Сега искате да копирате всички редове от тези работни листове, чиято колона C съдържа текста „Завършено“ в нов работен лист. Как можете да разрешите този проблем бързо и лесно, без да ги копирате и поставяте един по един ръчно?

Копирайте редове от множество работни листове въз основа на критерии в нов лист с VBA код


Копирайте редове от множество работни листове въз основа на критерии в нов лист с VBA код

Следният VBA код може да ви помогне да копирате конкретни редове от всички работни листове в работната книга въз основа на определено условие в нов работен лист. Моля, направете следното:

1. Задръжте натиснат ALT + F11 за да отворите Microsoft Visual Basic за приложения прозорец.

2. Щракнете Поставете > Модулии поставете следния код в прозореца на модула.

VBA код: Копирайте редове от няколко листа въз основа на критерии в нов лист

Public Sub CopyRows_ValuesAndNumberFormats()
Dim xWs As Worksheet
Dim xCWs As Worksheet
Dim xRg As Range
Dim xStrName As String
Dim xRStr As String
Dim xRRg As Range
Dim xC As Integer
On Error Resume Next
Application.DisplayAlerts = False
xStr = "Kutools for Excel"
xRStr = "Completed"
Set xCWs = ActiveWorkbook.Worksheets.Item(xStr)
If Not xCWs Is Nothing Then
    xCWs.Delete
End If
Set xCWs = ActiveWorkbook.Worksheets.Add
xCWs.Name = xStr
xC = 1
For Each xWs In ActiveWorkbook.Worksheets
    If xWs.Name <> xStr Then
        Set xRg = xWs.Range("C:C")
        Set xRg = Intersect(xRg, xWs.UsedRange)
        For Each xRRg In xRg
            If xRRg.Value = xRStr Then
               xRRg.EntireRow.Copy
               xCWs.Cells(xC, 1).PasteSpecial xlPasteValuesAndNumberFormats
               xC = xC + 1
            End If
        Next xRRg
    End If
Next xWs
Application.DisplayAlerts = True
End Sub

Забележка: В горния код:

  • Текстът "XNUMXавършен" в това xRStr = "Завършено" скрипт указва конкретното условие, въз основа на което искате да копирате редове;
  • C:C в тази Задайте xRg = xWs.Range("C:C") скрипт указва конкретната колона, където се намира условието.

3. След това натиснете F5 ключ за изпълнение на този код и всички редове със специфичното условие са копирани и поставени в нов работен лист с име Kutools за Excel в текущата работна книга. Вижте екранна снимка:


Още относителни статии с данни за изтегляне или копиране:

  • Копирайте данни в друг работен лист с разширен филтър в Excel
  • Обикновено можем бързо да приложим функцията за разширен филтър, за да извлечем данни от необработените данни в същия работен лист. Но понякога, когато се опитате да копирате филтрирания резултат в друг работен лист, ще получите следното предупредително съобщение. В този случай как бихте могли да се справите с тази задача в Excel?
  • Копирайте редове, ако колоната съдържа конкретен текст/стойност в Excel
  • Да предположим, че искате да намерите клетки, съдържащи конкретен текст или стойност в колона, и след това да копирате целия ред, където се намира намерената клетка, как бихте могли да се справите с това? Тук ще представя няколко метода за намиране дали колоната съдържа конкретен текст или стойност и след това ще копирам целия ред в Excel.

  • Супер Формула Бар (лесно редактиране на няколко реда текст и формула); Оформление за четене (лесно четене и редактиране на голям брой клетки); Поставяне във филтриран диапазон...
  • Обединяване на клетки/редове/колони и съхраняване на данни; Съдържание на разделени клетки; Комбинирайте дублиращи се редове и сума/средно... Предотвратяване на дублиращи се клетки; Сравнете диапазони...
  • Изберете Дублиран или Уникален редове; Изберете Празни редове (всички клетки са празни); Super Find и Fuzzy Find в много работни тетрадки; Произволен избор...
  • Точно копие Множество клетки без промяна на референтната формула; Автоматично създаване на препратки към множество листа; Вмъкване на куршуми, квадратчета за отметка и други...
  • Любими и бързо вмъкнати формули, диапазони, диаграми и снимки; Шифроване на клетки с парола; Създаване на пощенски списък и изпращайте имейли...
  • Извличане на текст, Добавяне на текст, Премахване по позиция, Премахване на пространството; Създаване и отпечатване на междинни суми за пейджинг; Конвертиране на съдържание и коментари между клетки...
  • Супер филтър (запазване и прилагане на филтърни схеми към други листове); Разширено сортиране по месец/седмица/ден, честота и други; Специален филтър с удебелен шрифт, курсив...
  • Комбинирайте работни тетрадки и работни листове; Обединяване на таблици въз основа на ключови колони; Разделете данните на няколко листа; Пакетно конвертиране на xls, xlsx и PDF...
  • Групиране на обобщена таблица по номер на седмицата, ден от седмицата и други... Показване на отключени, заключени клетки с различни цветове; Маркирайте клетки, които имат формула/име...
kte tab 201905
  • Разрешете редактиране и четене с раздели в Word, Excel, PowerPoint, Publisher, Access, Visio и Project.
  • Отваряйте и създавайте множество документи в нови раздели на един и същ прозорец, а не в нови прозорци.
  • Увеличава вашата производителност с 50% и намалява стотици кликвания на мишката за вас всеки ден!
officetab отдолу
Comments (2)
No ratings yet. Be the first to rate!
This comment was minimized by the moderator on the site
Hi,

thank you very much for the code. I have a question: the code runs smoothly on some of my sheets, but looks like enters an infinite loop in some other ones which makes excel crash. What could the reason be?
This comment was minimized by the moderator on the site
Hello there, thank you so much for the code above, it solved me a problem with a complex file; a solution I have been looking for a while now. Thank you..I have one question. How do I change the code so that it copies the rows but only from colum A to colum Q, so not Entire.Row?Thank you in advance and great work!
There are no comments posted here yet
Please leave your comments in English
Posting as Guest
×
Rate this post:
0   Characters
Suggested Locations