对于每一行，按预定义列复制特定单元格，并将值粘贴到单独工作表中的备用预定义列中

I have to select data from one Excel worksheet and copy into into a different worksheet, however I need to achieve the following during the process of copying my data over:

我必须从一个Excel工作表中选择数据并复制到另一个工作表中，但是我需要在复制数据的过程中实现以下目的：

• For each row of the original worksheet, select cells by column (which I can predefine, perhaps using an array or something).

  对于原始工作表的每一行，按列选择单元格（我可以预定义，也许使用数组或其他内容）。

• Manipulate the data to change the orientation of it in the new worksheet. See screenshot below.

  处理数据以更改新工作表中的方向。见下面的截图。

It's difficult to explain exactly what I mean so I hope my screenshot will communicate what I need.

很难准确解释我的意思所以我希望我的截图能够传达我所需要的东西。

For each row there is a channel value, I need to order and condense all results by channel. There is also a need to check results against a limit but I can cross that after this problem is solved.

对于每一行都有一个通道值，我需要按通道排序和压缩所有结果。还需要针对限制检查结果，但是在解决此问题后我可以跨过该限制。

I have my code below, I appreciate that there may be errors as this is my first script. Never mind ordering the data by channel I am struggling so far to even select the columns I want and copy them exactly over to the new worksheet.

我在下面有我的代码，我感谢可能有错误，因为这是我的第一个脚本。没关系按渠道排序数据我到目前为止都在努力甚至选择我想要的列并将它们完全复制到新工作表中。

The first part of code is to check and create a new worksheet. After that it goes on to define the variables and arrays that I can predefine the columns I want to. It finishes with a loop that checks through x number of rows (although I do want it to iterate for as many rows as there are) and inside that there is another loop for each row, grabs the cell based on my predefined columns.

代码的第一部分是检查并创建一个新的工作表。之后，它继续定义变量和数组，我可以预定义我想要的列。它完成了一个循环，它检查x行数（尽管我希望它迭代尽可能多的行），并且内部每行有另一个循环，根据我的预定义列抓取单元格。

When debugging, it shows up as an object or application error on the sheet copying function right at the bottom inside the loops. I'm not sure where I'm going wrong. Where am I going wrong and is there a better way to attack this?

在调试时，它会在循环内部底部的工作表复制功能中显示为对象或应用程序错误。我不确定我哪里出错了。我哪里出错了，是否有更好的方法来攻击它？

Sub Process_Results()

'User defines the worksheets for this script
sourcedatasheet_name = InputBox("Enter the customer data sheet name: ", "Enter Worksheet Name")

For rep = 1 To (Worksheets.Count)
    If LCase(Sheets(rep).Name) = LCase(sourcedatasheet_name) Then
        Exit For
    ElseIf (rep = Worksheets.Count) And (LCase(Sheets(rep).Name) <> LCase(sourcedatasheet_name)) Then
        MsgBox "This sheet does not exist!"
        Exit Sub
    End If
Next

destinationdatasheet_name = InputBox("Enter the destination worksheet name to write the data to: ", "Enter Destination Worksheet Name")
For rep = 1 To (Worksheets.Count)
    If LCase(Sheets(rep).Name) = LCase(destinationdatasheet_name) Then
        MsgBox "This sheet already exists!"
        Exit Sub
    End If
Next

Sheets.Add After:=Sheets(Sheets.Count)
Sheets(ActiveSheet.Name).Name = destinationdatasheet_name

'These are the variables for referencing data sets in the source sheet
Dim source_testmodel
Dim source_testcasename
Dim source_measurementname
Dim source_carrierfrequency
Dim source_limitlow
Dim source_limithigh
Dim source_measuredresult
Dim source_measurementunit

'These are the variables for referencing data set columns in the processed data sheet
Dim destination_testmodel
Dim destination_testcasename
Dim destination_measurementname
Dim destination_carrierfrequency_bottomchannel
Dim destination_carrierfrequency_middlechannel
Dim destination_carrierfrequency_topchannel
Dim destination_measuredresult

'Define the column number and cell column reference for each data set that will be used to retrieve information from the source sheet
source_testmodel = 9
source_testname = 11
source_measurementname = 12
source_measuredcarrierfrequency = 13
source_measurementlimitlow = 15
source_measurementlimithigh = 16
source_measuredresult = 17
source_measurementunit = 18

Dim array_source_fields(8) As Variant
array_source_fields(1) = source_testmodel
array_source_fields(2) = source_testname
array_source_fields(3) = source_measurementname
array_source_fields(4) = source_measuredcarrierfrequency
array_source_fields(5) = source_measurementlimitlow
array_source_fields(6) = source_measurementlimithigh
array_source_fields(7) = source_measuredresult
array_source_fields(8) = source_measurementunit

'Define the column number and cell column reference for each data set that will be used to write information to the processing sheet
destination_testmodel = 1
destination_testname = 2
destination_measurementname = 3
destination_channelbottom = 4
destination_channelmiddle = 5
destination_channeltop = 6

Dim array_processed_fields(6) As Variant
array_processed_fields(1) = destination_testmodel
array_processed_fields(2) = destination_testname
array_processed_fields(3) = destination_measurementname
array_processed_fields(4) = destination_channelbottom
array_processed_fields(5) = destination_channelmiddle
array_processed_fields(6) = destination_channeltop

'Start processing data

Dim y As Variant
Dim lastrow As Long


For x = 1 To 100 'row 'lastrow=activesheet.usedrange.specialcells(xlCellTypeLastCell)
    For Each y In array_source_fields 'y = LBound(Application.Transpose(array_source_fields)) To UBound(Application.Transpose(array_source_fields))
        Sheets(sourcedatasheet_name).Cells(x, y).Copy Destination:=Sheets(destinationdatasheet_name).Cells(x, y)
    Next y


Next x




End Sub

2 个解决方案

#1

There are multiple way to solve this! The following three can be found in this file.

有多种方法可以解决这个问题！可以在此文件中找到以下三个。

1. Pivot table

1.数据透视表

1. Insert tab->Tables->PivotTable
2. Insert tab-> Tables-> PivotTable
3. Select you data as range to analyze and click okay
4. 选择数据作为分析范围，然后单击“确定”
5. Drag the field Mode to "Row Labels" box, "Channel" to the column "Column Labels" and "Results" to "Values"
6. 将字段模式拖动到“行标签”框，将“通道”拖动到“列标签”列，将“结果”拖动到“值”
7. PivotTable Tools->Design tab->Layout->Grand Totals->Off for Rows and Columns
8. 数据透视表工具 - >设计选项卡 - >布局 - >总计 - >关闭行和列

Done!

完成！

2. Formula

2.公式

This solution is only applicable, if the name of the modes and channels are known:

如果已知模式和通道的名称，则此解决方案仅适用：

1. Place all the mode names in the first column, all the channel names in the first row, i.e. create header rows. In the below formula, I assume, that the header row is row 1 and the header column is A in sheet2 and that you data is in Sheet1, starting in cell A1
2. 将所有模式名称放在第一列中，将所有通道名称放在第一行中，即创建标题行。在下面的公式中，我假设标题行是第1行，标题列是Sheet2中的A，并且数据是在Sheet1中，从单元格A1开始
3. In cell B2, enter the following formula:
4. 在单元格B2中，输入以下公式：

=INDEX(Sheet1!$D$2:$D$10,MATCH($A2&"_"&B$1,Sheet1!$A$2:$A$10&"_"&Sheet1!$C$2:$C$10,0))

This is an array formula, i.e. enter it with Ctrl-Shift-Enter 3. Copy the formula all remaining cells in the table

这是一个数组公式，即使用Ctrl-Shift-Enter输入3.将公式中的所有剩余单元格复制到表中

3. Macro

3.宏观

This macro will do the job - though it assumes that modes and channels are sorted. You need to name the top-left cell of your result table rngHeader and then run this code:

这个宏将完成这项工作 - 尽管它假定模式和通道已排序。您需要为结果表rngHeader的左上角单元命名，然后运行以下代码：

Sub FillTable()
    Dim rngSource As Range, rngTarget As Range
    Dim lngModeCount As Long, lngChannelCount As Long

    Set rngSource = Range("A2")
    Set rngTarget = Range("rngHeader")

    'Clear old result
    With rngTarget
        If .Offset(1) <> "" And .Offset(, 1) <> "" Then
            .Resize(.End(xlDown).Row - .Row + 1, .End(xlToRight).Column - .Column + 1).Clear
            rngTarget = "(cell is named ""rngHeader"")"
        End If
    End With

    While rngSource.Value <> ""
        If rngSource.Offset(-1) <> rngSource Then
            lngModeCount = lngModeCount + 1
            lngChannelCount = 0
            rngTarget.Offset(lngModeCount) = rngSource
            rngTarget.Offset(lngModeCount).Font.Bold = True
        End If
        lngChannelCount = lngChannelCount + 1
        If lngModeCount = 1 Then
            rngTarget.Offset(, lngChannelCount) = rngSource.Offset(, 2)
            rngTarget.Offset(, lngChannelCount).Font.Bold = True
        End If
        rngTarget.Offset(lngModeCount, lngChannelCount) = rngSource.Offset(, 3)
        Set rngSource = rngSource.Offset(1)
    Wend

End Sub

#2

By the way, here is some code that would do what you want:

顺便说一句，这里有一些代码可以做你想要的：

Const FIRST_CELL_IN_SOURCE_DATA = "$A$4"
Const FIRST_CELL_IN_DEST_DATA = "$A$2"

Const COL_SOURCE_MODE = 0
Const COL_SOURCE_DESC = 1
Const COL_SOURCE_CHANNEL = 2
Const COL_SOURCE_RESULT = 3
Const COL_SOURCE_LIMIT = 4

Const COL_DEST_MODE = 1
Const COL_DEST_DESC = 1
Const COL_DEST_RESULT = 4
Const COL_DEST_FIRST_CHANNEL = 3

Const ROW_DEST_HEADER = 1

Private wksSource As Worksheet
Private wksDest As Worksheet

Sub Process_Results()

If GetSourceSheet = False Then Exit Sub
If CreateDestinationSheet = False Then Exit Sub
CopyDataSet

End Sub

Private Function GetSourceSheet() As String

'User defines the worksheets for this script
sourcedatasheet_name = InputBox("Enter the customer data sheet name: ", "Enter Worksheet Name")

For rep = 1 To (Worksheets.Count)
    If LCase(Sheets(rep).Name) = LCase(sourcedatasheet_name) Then
        Exit For
    ElseIf (rep = Worksheets.Count) And (LCase(Sheets(rep).Name) <> LCase(sourcedatasheet_name)) Then
        MsgBox "This sheet does not exist!"
        Exit Function
    End If
Next

Set wksSource = Sheets(sourcedatasheet_name)
GetSourceSheet = True

End Function

Private Function CreateDestinationSheet() As String

destinationdatasheet_name = InputBox("Enter the destination worksheet name to write the data to: ", "Enter Destination Worksheet Name")
For rep = 1 To (Worksheets.Count)
    If LCase(Sheets(rep).Name) = LCase(destinationdatasheet_name) Then
        MsgBox "This sheet already exists!"
        Exit Function
    End If
Next

Sheets.Add After:=Sheets(Sheets.Count)
Sheets(ActiveSheet.Name).Name = destinationdatasheet_name

Set wksDest = Sheets(destinationdatasheet_name)
AddHeaders
CreateDestinationSheet = True

End Function

Private Sub CopyDataSet()

Dim rngSourceRange As Range
Dim rngDestRange As Range

Set rngSourceRange = wksSource.Range(FIRST_CELL_IN_SOURCE_DATA)
Set rngDestRange = wksDest.Range(FIRST_CELL_IN_DEST_DATA)
rngDestRange.Activate

Do Until rngSourceRange.Value = ""
    CopyRowToDest rngSourceRange, rngDestRange
    Set rngSourceRange = rngSourceRange.Offset(1)
Loop

End Sub

Private Sub AddHeaders()

Dim rng As Range
Set rng = wksDest.Cells(ROW_DEST_HEADER, 1)

rng.Value = "Mode"
rng.Offset(, 1).Value = "Test"

End Sub

Private Function GetColumnForChannel(ByVal Channel As String) As Long

Dim rng As Range
Set rng = wksDest.Cells(ROW_DEST_HEADER, COL_DEST_FIRST_CHANNEL)

Do Until rng.Value = ""
    If rng.Value = Channel Then
        GetColumnForChannel = rng.Column - 1
        Exit Function
    End If
    Set rng = rng.Offset(, 1)
Loop

rng.Value = Channel
GetColumnForChannel = rng.Column - 1

End Function

Private Sub MoveToModeRow(ByVal Mode As String)

If ActiveCell.Value = Mode Then Exit Sub

If ActiveCell.Address = FIRST_CELL_IN_DEST_DATA And ActiveCell.Value = "" Then
    ActiveCell.Value = Mode
    Exit Sub
End If

If Val(ActiveCell.Value) < Val(Mode) And ActiveCell.Offset(1).Value = "" Then
    ActiveCell.Offset(1).Activate
    ActiveCell.Value = Mode
    Exit Sub
End If

Dim rng As Range
Set rng = wksDest.Range(FIRST_CELL_IN_DEST_DATA)

Do Until rng.Value = ""
    If rng.Value = Mode Then
        rng.Activate
        Exit Sub
    End If
    Set rng = rng.Offset(1)
Loop

rng.Value = Mode
rng.Activate

End Sub



Private Sub CopyRowToDest(ByRef rngSourceRange As Range, ByRef rngDestRange As Range)

MoveToModeRow rngSourceRange.Offset(, COL_SOURCE_MODE).Value

Dim lngCol As Long
lngCol = GetColumnForChannel(rngSourceRange.Offset(, COL_SOURCE_CHANNEL).Value)

ActiveCell.Offset(, lngCol).Value = rngSourceRange.Offset(, COL_SOURCE_RESULT).Value
ActiveCell.Offset(, COL_DEST_DESC).Value = rngSourceRange.Offset(, COL_SOURCE_DESC).Value

End Sub