Alshaikhli Ответов: 3

Скопируйте столбцы с условием

Хии,
У меня есть два листа в моем файле Excel,поэтому я хочу выбрать и скопировать столбцы (Part_Number,Name,Version, Level) из листа 1 в лист 2 в одной книге, когда столбец (Level) включает ячейку >1.

приведенный ниже код копирует столбцы с рабочего листа 1 на рабочий лист 2,но я все еще не могу установить условие
кто-нибудь может мне помочь?
Спасибо

Что я уже пробовал:

Sub OneCell()
    Sheets("sheet1").Select
    Range("A1:A100").Copy    'Part_Number column'
    Range("F1:F100").Copy    'Name column'
    Range("H1:H100").Copy     'Version column'
    Range("M1:M100").Copy     'Version Level'
    Sheets("sheet2").Select
    Range("A1:A100").Select
    Range("F1:F100").Select
    Range("H1:H100").Select
    Range("M1:M100").Select
    ActiveSheet.Paste
End Sub

ZurdoDev

Вы хотите скопировать весь столбец, если уровень имеет хотя бы одну ячейку больше 1? Или вы хотите скопировать только те строки, где уровень выше 1?

Alshaikhli

я мог бы вам помочь мне с этим , я хочу скопировать все строки в (Part_Number,Name,Version,Level columns), когда строка в столбце Level & gt; 1. Спасибо

ZurdoDev

Вам нужно сделать петлю по клеткам. Просто Google excel VBA loop через ячейки.

3 Ответов

Рейтинг:
21

Maciej Los

Предположим, что вы хотите скопировать данные с одного листа на другой, когда будет выполнено определенное условие (Level>1), вы можете достичь этого двумя способами:


  1. С помощью Объект adodb.Записей[^] + Диапазон.Метод CopyFromRecordset[^]
    Этот метод действительно быстрый!
    'needs reference to Microsoft ActiveX Data Object Library x.x
Sub CopyData1()
Dim oConn As ADODB.Connection, oRst As ADODB.Recordset
Dim sConn As String, sSql As String

On Error GoTo Err_CopyData1

'define conection string to itself (this workbook)
sConn = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & ThisWorkbook.FullName & ";Extended Properties='Excel 12.0 Macro;HDR=YES';"
'create and open connection
Set oConn = New ADODB.Connection
With oConn
    .ConnectionString = sConn
    .Open
End With
'define query
sSql = "SELECT [Part_Number], [Name], [Version], [Level]" & vbCr & _
    "FROM [Sheet1$A1:D100]" & vbCr & _
    "WHERE [Level]>1;"
'create and open recordset
Set oRst = New ADODB.Recordset
oRst.Open sSql, oConn, adOpenStatic, adLockReadOnly

'context!!!
With ThisWorkbook.Worksheets("Sheet2")
    'clear precious data
    .Range("A2:D10000").Delete xlShiftUp
    'insert filtered data
    .Range("A2").CopyFromRecordset oRst
End With

'exit subroutine
Exit_CopyData1:
    'ignore errors and clean up
    On Error Resume Next
    If Not oConn Is Nothing Then oConn.Close
    Set oConn = Nothing
    If Not oRst Is Nothing Then oRst.Close
    Set oRst = Nothing
    Exit Sub

'error handler
Err_CopyData1:
    MsgBox Err.Description, vbExclamation, Err.Number
    Resume Exit_CopyData1
End Sub
  2. С помощью for... next или Do/While Loop петля
    Этот метод медленнее, чем описанный выше.
    Sub CopyData2()
Dim srcWsh As Worksheet, dstWsh As Worksheet
Dim i As Integer, j As Integer

On Error GoTo Err_CopyData2

'define context
Set srcWsh = ThisWorkbook.Worksheets("Sheet1")
Set dstWsh = ThisWorkbook.Worksheets("Sheet2")

'clear range before you start copying
dstWsh.Range("A2:D10000").Clear

'starting rows
i = 2
j = 2
'loop though the data
Do While srcWsh.Range("A" & i) <> ""
    'go to skip soubroutine if Level is equal to 1
    If srcWsh.Range("D" & i) = 1 Then GoTo SkipThisRow
    'copy set of columns - in this case A to D, but it might be: A, C, E, G
    With dstWsh
        .Range("A" & j) = srcWsh.Range("A" & i)
        .Range("B" & j) = srcWsh.Range("B" & i)
        .Range("C" & j) = srcWsh.Range("C" & i)
        .Range("D" & j) = srcWsh.Range("D" & i)
    End With
    'increase row number in Sheet2
    j = j + 1
'skip subroutine
SkipThisRow:
    'increase row number in Sheet1
    i = i + 1
Loop

'exit subroutine
Exit_CopyData2:
    On Error Resume Next
    Set srcWsh = Nothing
    Set dstWsh = Nothing
    Exit Sub

'error handler
Err_CopyData2:
    MsgBox Err.Description, vbExclamation, Err.Number
    Resume Exit_CopyData2
End Sub



Выберите метод, который вы предпочитаете. Измените код в соответствии с вашими потребностями. И, наконец, пожалуйста, прочтите статью MSDN о Лучшие практики кодирования производительности Excel VBA[^]

[РЕДАКТИРОВАТЬ]
Я добавил совет/статью с исходным файлом в базу данных CodeProject на основе этого вопроса. Вы можете скачать его и протестировать на своем компьютере.
Пожалуйста, смотрите: Копирование данных между листами Excel с помощью VBA[^]

ZurdoDev

+5 Очень приятно.

Maciej Los

Спасибо, Райан.

Alshaikhli

я использовал второй метод, он работает отлично.Еще раз спасибо Мацей Лос.

Maciej Los

Всегда пожалуйста.

Рейтинг:
2

Patrice T

Цитата:
приведенный ниже код копирует столбцы с рабочего листа 1 на рабочий лист 2,но я все еще не могу установить условие
кто-нибудь может мне помочь?

При копировании диапазона не существует никаких условий.

Если я что-то не упустил, это не то, что вы описали, даже без условия.
Sub OneCell()
    Sheets("sheet1").Select
    Range("A1:A100").Copy    'Part_Number column'
    Range("F1:F100").Copy    'Name column'
    Range("H1:H100").Copy     'Version column'
    Range("M1:M100").Copy     'Version Level'
    Sheets("sheet2").Select
    Range("A1:A100").Select
    Range("F1:F100").Select
    Range("H1:H100").Select
    Range("M1:M100").Select
    ActiveSheet.Paste
End Sub

Чтобы увидеть, как excel это делает, запишите макрос, пока вы делаете это вручную, это очень полезная функция для изучения Excel VBA.

Пример кода, близкий к вашим потребностям, обратите внимание, что пропущенные строки делают отверстия в целевом листе:
Sub Alshaikhli_copy()
    Set WSSource = Sheets("sheet1")
    Set WSTarget = Sheets("sheet2")
    ' loop on 100 rows
    For Line = 1 To 100
        ' test condition in column D
        If WSSource.Cells(Line, 4).Value > 1 Then
            ' copy columb A
            WSSource.Cells(Line, 1).Copy WSTarget.Cells(Line, 1)
            ' copy columb B
            WSSource.Cells(Line, 2).Copy WSTarget.Cells(Line, 2)
        End If
    Next
End Sub

Alshaikhli

Большое вам спасибо за ваши усилия!

Рейтинг:
1

CHill60

Вот один из способов сделать это:

Option Explicit
Public Sub CopyColumns()

    Dim targetRow As Integer
    targetRow = 1
    
    Dim sourceRow As Integer
    For sourceRow = 1 To Worksheets(1).UsedRange.Rows.Count
                
        Dim r As Range
        Set r = Worksheets(1).Range("M" + CStr(sourceRow))
        If r.Value2 > 1 Then
            
            Worksheets(1).Activate
            Worksheets(1).Range("A" + CStr(sourceRow) + ",F" + CStr(sourceRow) + ",H" + CStr(sourceRow) + ",M" + CStr(sourceRow)).Select
            Selection.Copy

            Worksheets(2).Activate
            Worksheets(2).Range("A" + CStr(targetRow)).Select
            ActiveSheet.Paste
            
            targetRow = targetRow + 1
        End If
    Next
    
End Sub
Некоторые вещи, чтобы отметить:
- не забудьте активировать или выбрать каждый лист перед копированием или вставкой, иначе вы получите (бесполезную) ошибку
Цитата:
---------------------------
Microsoft Visual Basic для приложений
---------------------------
Ошибка времени выполнения '1004':

Ошибка, определяемая приложением или объектом
---------------------------
Хорошо помогите
---------------------------

- Обратите внимание, как я выбрал диапазон элементов для копирования. Для строки 1 Этот диапазон будет выглядеть следующим образом Worksheets(1).Range("A1,F1,H1,M1").Select
- Я использовал индекс для каждого листа, а не имена "Лист1", "Лист2" - если кто-то переименует их, этот суб все равно будет работать.
- Я уже использовал UsedRange для исходного листа, так что этот суб будет пропускать пробелы в данных.
- Я проверяю против Value2 (не значение или текст), чтобы убедиться, что я получаю фактическое содержимое ячейки (независимо от форматирования или ширины столбца)

Maciej Los

Кэролайн, пожалуйста, не рекомендую использовать Activate и Select метод. Это плохая практика. Я уже упоминал об этом. Вместо этого вы должны использовать код в определенном контексте. Copy + Paste это еще одна плохая практика. Я приведу более подробную информацию в своем ответе.

[РЕДАКТИРОВАТЬ]
Уже отправлено.

CHill60

Спасибо за обратную связь Мацей - очень ценю. Я собираюсь внимательно прочитать статью в вашем решении :)

Alshaikhli

Большое вам спасибо за ваши усилия!