sheet1里A列筛选出G1，然后把C列的数据复制到G1表（从D列三行开始贴贴)。然后再筛选G2

Question

sheet1里A列筛选出G1，然后把C列的数据复制到G1表（从D列三行开始贴贴)。然后再筛选G2把C列的数据复制到G2表，也是从D列第三行开始贴……一直要做到G11
求vb代码，谢谢

Answer 1

Sub 透视表showdetail()

    Dim Savedir As String
    Dim Finalrow As Long, Finalcol As Long
    Dim Nrow As Long, Ncol As Long
   
    Dim Dbbook As Workbook, Basewks As Worksheet, Pivotwks As Worksheet
       
    Dim Fname As Variant
    Dim Fnum As Integer
    Dim Res As Boolean
    
    Dim Sourcerange As Range
    Dim Ptrange As Range
    
    Dim Pname As String
    Dim Pcache As PivotCache
    Dim PT As PivotTable
    
    Dim CustItem As Variant
    
    Dim RowF, DataF As String
    
    
    '查找最后行与列
    
    Set Basewks = ActiveSheet
    Basewks.Select
    Nrow = Basewks.UsedRange.Rows.Count
    Finalrow = Basewks.UsedRange.Rows(Nrow).Row
    
    Ncol = Basewks.UsedRange.Columns.Count
    Finalcol = Basewks.UsedRange.Columns(Ncol).Column
    
    '选择数据透视表的数据源
    Set Sourcerange = Basewks.Range(Basewks.Cells(1, 1), Basewks.Cells(Finalrow, Finalcol))
    
    Pname = "透视表"
    
    '建立数据透视表cache
    Set Pcache = ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:=Sourcerange.Address)
    
    '添加一个新表，透视表命名为“透视表”
    Worksheets.Add after:=Basewks
        
    Set Pivotwks = ActiveSheet
    
    Pivotwks.Name = Pname
    
        
    '检查透视表，如果有就删除
    For Each PT In Pivotwks.PivotTables
    
        PT.TableRange2.Clear
    
    Next PT
        
    '从数据透视表缓存建立透视表
    Set PT = Pcache.CreatePivotTable(TableDestination:=Pivotwks.Cells(3, 1), TableName:=Pname)
    
    '关闭自动刷新
    'PT.ManualUpdate = True
    
    
    '输入行标签：字段
    RowF = "group"
    '输入数据区：字段
    DataF = "id"
    
    '添加数据表项目
    '添加行，根据需要添加相应的项目
    PT.AddFields RowFields:=RowF

    '添加数据区，根据需要添加相应的数据
    With PT.PivotFields(DataF)
        .Orientation = xlDataField
        .Function = xlSum
        .Position = 1
        
    End With
    
    ctr = 0
    
    '历遍所有透视表项目
    For Each CustItem In PT.PivotFields(RowF).PivotItems
        
        ctr = ctr + 1
        
        '根据透视表拆分对应的明细表
        PT.TableRange2.Offset(ctr, 1).Resize(1, 1).ShowDetail = True
        '重命名拆分后的明细表        
        ActiveSheet.Name = CustItem.Name
        
        
        '明细表拆分为单个文件，保存为截短后的名称
        'ActiveSheet.Copy
        
        'ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & ActiveSheet.Name & ".xlsx"
        'ActiveWorkbook.Close
        
        
    Next CustItem
  

    
End Sub

Answer 2

我用的是VBA，不知可否？
Public Sub 筛选()
    Dim CXrng As Range, XRrng As Range
    For Each CXrng In Range("A2:A" & Range("a" & Rows.Count).End(xlUp).Row)
        If CXrng <> "" Then
            If Sheets(CXrng.Value).Range("D3").Value = "" Then
                Set XRrng = Sheets(CXrng.Value).Range("D3")
            Else
                Set XRrng = Sheets(CXrng.Value).Range("D" & Sheets(CXrng.Value).Range("D" & Rows.Count).End(xlUp).Row).Offset(1, 0)
            End If
            XRrng.Value = CXrng.Offset(0, 2).Value
        End If
    Next
End Sub

追问

太厉害了，再问一下，如果是筛选以后 把 E列 的数据复制到 其他各表，应该怎么改

本回答被提问者和网友采纳