автоматическое копирование избранных столбцов на новый рабочий лист

Question

Я довольно новый, чтобы преуспеть, и мне было интересно, есть ли более простой способ сделать рутину для копирования вручную. У меня есть рабочий лист, который имеет длинный список столбцов, который выглядит следующим образом:

Name  Age Occupation Major WorkEx  Position..... 

Я хочу макрос скопировать некоторые заранее определенные столбцы из листа 1 до рабочего листа 2, т.е. каждый раз, когда я скопировать исходные данные в таблицу 1 лист- должен быть автоматически заполнен выбранными столбцами. В этом случае, например, если я вставляю вышеупомянутые столбцы в рабочий лист 1, то имя, майор и позиция должны автоматически копироваться на рабочий лист 2.

Следует отметить, что необработанные данные не всегда в порядке, как показано на рисунке выше. Я считаю, что ключ состоит в том, чтобы найти/найти заголовок, а затем скопировать весь столбец на рабочий лист 2 в определенных столбцах.

В этом случае рабочий лист 2 всегда будет иметь столбцы 8-10 и полные 16 как пустые.

Может ли кто-нибудь помочь мне с этой проблемой? Сообщите мне, нужны ли какие-либо дополнительные данные.

Answer 1

Попробуйте это. Просто замените test1 на имена столбцов и т. Д.
Не забудьте добавить номер столбца вместо targetCol, как вы хотите его жестко кодировать. Я использовал объект диапазона для копирования данных.

Option Explicit 

Sub CopyCode() 

'Declaring the variable lColumn as long to store the last Column number 
Dim lColumn As Long 
'Declaring the variable iCntr as long to use in the For loop 
Dim iCntr As Long 
Dim lastRow As Long 
Dim lastCol As Long, targetCol As Long 
Dim wks As Worksheet, targetWks As Worksheet 
Dim rng As Range 
Dim fCol As String 

' Set wks so it is the activesheet 
Set wks = ThisWorkbook.Sheets("Sheet1") 

Set targetWks = ThisWorkbook.Sheets("Sheet2") 

    lastCol = wks.Cells(1, wks.Columns.Count).End(xlToLeft).Column 


'Assigning the last Column value to the variable lColumn 
lColumn = lastCol 

'Using for loop 
For iCntr = lColumn To 1 Step -1 

    If LCase(wks.Cells(1, iCntr)) Like LCase("Test1") Then 
     ' Find column letter 
     fCol = GetColumnLetter(iCntr) 
     lastRow = wks.Range(fCol & wks.Rows.Count).End(xlUp).Row 

     ' Declare range object 
     Set rng = wks.Range(fCol & "2:" & fCol & lastRow) 

     ' Use Range object to copy data 
     rng.Copy _ 
     Destination:=targetWks.Cells(1, targetCol) ' Replace targetCol with number of column (A=1, B=2, etc.) 
    End If 

    If LCase(wks.Cells(1, iCntr)) Like LCase("Test2") Then 
     ' Find column letter 
     fCol = GetColumnLetter(iCntr) 
     lastRow = wks.Range(fCol & wks.Rows.Count).End(xlUp).Row 

     ' Declare range object 
     Set rng = wks.Range(fCol & "2:" & fCol & lastRow) 

     ' Use Range object to copy data 
     rng.Copy _ 
     Destination:=targetWks.Cells(1, targetCol) ' Replace targetCol with number of column (A=1, B=2, etc.) 
    End If 

    If LCase(wks.Cells(1, iCntr)) Like LCase("Test") Then 
     ' Find column letter 
     fCol = GetColumnLetter(iCntr) 
     lastRow = wks.Range(fCol & wks.Rows.Count).End(xlUp).Row 

     ' Declare range object 
     Set rng = wks.Range(fCol & "2:" & fCol & lastRow) 

     ' Use Range object to copy data 
     rng.Copy _ 
     Destination:=targetWks.Cells(1, targetCol) ' Replace targetCol with number of column (A=1, B=2, etc.) 
    End If 

    ' etc etc 
Next 

End Sub 

Function GetColumnLetter(colNum As Long) As String 
    Dim vArr 
    vArr = Split(Cells(1, colNum).Address(True, False), "$") 
    GetColumnLetter = vArr(0) 
End Function