Excel VBA - 转置，复制并粘贴到不同的行，条件

Question

我是全新的VBA在Excel中。

我的数据由G列和奖牌列表组成，H列代表国家。我想转置我的国家奥委会，让J栏代表金牌，其余的则是其他奖牌（只要他们在同一行，顺序无论是银色还是铜色都不重要）。请参考下面的图片，这对我想要做的事情是不言而喻的。

我试着对VBA进行编码，这样它就可以在列和转置之间进行三次复制，但是它有很多次不经过三次。有时候有两枚铜牌，有时候没有铜牌。

我认为它可以工作的是阅读G列，然后沿着列向下寻找Gold，如果找到“Gold”，那么我希望它转置下一列H的值，直到下一个Gold在G列中找到。

下面的红色箭头指示的附加图像是我想要做的。

我将非常感谢您的帮助。

what i want to do

== 我设法解决我的问题与计算器的帮助，这就是结果。

Public Sub RunSQL() 
    Dim conn As Object, rst As Object 
    Dim strConnection As String, strSQL As String 
    Dim i As Integer 

    Set conn = CreateObject("ADODB.Connection") 
    Set rst = CreateObject("ADODB.Recordset") 

    ' CONNECTION STRING 
    strConnection = "DRIVER={Microsoft Excel Driver (*.xls, *.xlsx, *.xlsm, *.xlsb)};" _ 
        & "DBQ=C:\Path\To\Current\Workbook.xlsm;" 
    ' SQL STATEMENT 
    strSQL = "TRANSFORM MAX(m.NOC) AS CountryCode" _ 
     & " SELECT m.[Event], m.[Event Gender]" _ 
     & " FROM (SELECT t.[Event], t.[Event Gender], t.[Medal], t.NOC," _ 
     & "    (SELECT Count(*) FROM [MAIN$] sub" _ 
     & "    WHERE sub.[Event] = t.[Event]" _ 
     & "     AND sub.[Event Gender] = t.[Event Gender]" _ 
     & "     AND sub.[Medal] = t.[Medal]" _ 
     & "     AND (IIF(sub.[Medal]='Gold', 1, IIF(sub.[Medal]='Silver', 2, 3)) <" _ 
     & "      IIF(t.[Medal]='Gold', 1, IIF(t.[Medal]='Silver', 2, 3))" _ 
     & "      OR sub.[NOC] <= t.[NOC])) AS rn" _ 
     & "  FROM [MAIN$] t) m" _ 
     & " GROUP BY m.[Event], m.[Event Gender]" _ 
     & " PIVOT m.[Medal] & m.[rn] IN" _ 
     & "  ('Gold1', 'Gold2', 'Gold3', 'Silver1', 'Silver2', 'Silver3'," _ 
     & "  'Bronze1', 'Bronze2', 'Bronze3')" 

    ' OPEN DB CONN 
    conn.Open strConnection 
    rst.Open strSQL, conn 

    ' COLUMN HEADERS 
    For i = 1 To rst.Fields.Count 
     Worksheets("RESULTS").Cells(1, i) = rst.Fields(i - 1).Name 
    Next i   

    ' DATA ROWS 
    Worksheets("RESULTS").Range("A2").CopyFromRecordset rst 

    rst.Close: conn.Close  
End Sub 

Answer 1

在调换它代替，你可以通过算法做到这一点：

'Find the last used row in a Column: column A in this example 
Dim LastRow As Long 
With ActiveSheet 
    LastRow = .Cells(.Rows.Count, "G").End(xlUp).Row 
End With 
MsgBox LastRow 

'http://www.rondebruin.nl/win/s9/win005.htm 

dim start as long 
dim finish as long 

for medal = 2 to lastrow 
    if thisworkbook.worksheets("worksheetname").cells(medal,7).value = "gold" then 
    start = medal 
     for next_medal = medal+1 to lastrow 
      if thisworkbook.worksheets("worksheetname").cells(next_medal,7).value = "gold" 
       finish = next_medal -1 'because it should not copy the next gold in the previous row of J 
       medal = next_medal-1'because it starts looking for the next gold the next round at -1 

       'copy/assign the cells you want to transpose: 
       for transposing = start to finish 
       thisworkbook.worksheets("worksheetname").cells(2+counter,10+transposing-start).value = thisworkbook.worksheets("worksheetname").cells(transposing,7).value 'writing the rest of the medals to the right of the first gold medal 
       next transposing 
       counter = counter + 1'ensuring the next row in J will be filled next time. 
      end if 
     next next_medal 
    end if 
next medal 

我VBA编译了，所以我写了它，无需验资，我希望你理解的想法:)

Answer 2

考虑一个SQL解决方案，特别是你在哪里运行crosstab query。用于Windows的Excel可以使用ADO连接到Jet/ACE SQL引擎（.dll文件）并查询当前工作簿。

下面假定数据驻留在名为主（在查询的，如果需要FROM子句变化）标签，并在名为空标签导致输出结果：

Public Sub RunSQL() 
    Dim conn As Object, rst As Object 
    Dim strConnection As String, strSQL As String 
    Dim i As Integer 

    Set conn = CreateObject("ADODB.Connection") 
    Set rst = CreateObject("ADODB.Recordset") 

    ' CONNECTION STRING 
    strConnection = "DRIVER={Microsoft Excel Driver (*.xls, *.xlsx, *.xlsm, *.xlsb)};" _ 
         & "DBQ=C:\Path\To\Current\Workbook.xlsm;" 
    ' SQL STATEMENT 
    strSQL = "TRANSFORM MAX(m.NOC) AS CountryCode" _ 
      & " SELECT m.[Event], m.[Event Gender]" _ 
      & " FROM (SELECT t.[Event], t.[Event Gender], t.[Medal], t.NOC," _ 
      & "    (SELECT Count(*) FROM [MAIN$] sub" _ 
      & "    WHERE sub.[Event] = t.[Event]" _ 
      & "     AND sub.[Event Gender] = t.[Event Gender]" _ 
      & "     AND sub.[Medal] = t.[Medal]" _ 
      & "     AND (IIF(sub.[Medal]='Gold', 1, IIF(sub.[Medal]='Silver', 2, 3)) <" _ 
      & "      IIF(t.[Medal]='Gold', 1, IIF(t.[Medal]='Silver', 2, 3))" _ 
      & "      OR sub.[NOC] <= t.[NOC])) AS rn" _ 
      & "  FROM [MAIN$] t) m" _ 
      & " GROUP BY m.[Event], m.[Event Gender]" _ 
      & " PIVOT m.[Medal] & m.[rn] IN" _ 
      & "  ('Gold1', 'Gold2', 'Gold3', 'Silver1', 'Silver2', 'Silver3'," _ 
      & "  'Bronze1', 'Bronze2', 'Bronze3')" 

    ' OPEN DB CONN 
    conn.Open strConnection 
    rst.Open strSQL, conn 

    ' COLUMN HEADERS 
    For i = 1 To rst.Fields.Count 
     Worksheets("RESULTS").Cells(1, i) = rst.Fields(i - 1).Name 
    Next i   

    ' DATA ROWS 
    Worksheets("RESULTS").Range("A2").CopyFromRecordset rst 

    rst.Close: conn.Close  
End Sub 

输入

输出UT