[已解决]根据已知的店铺明细，从表中提取这些店铺的相关数据，求VBA代码，谢谢

chensir

根据“主店表”里店铺名称，从“费用表”里把这些店的数据提取出来，并将值变为负数放在“提取转换表”里
其中“主店表”里店铺名称是变化的，每次变化后按新的店名提取数据。
PS：如果“费用表”里没有“主店表”里店铺名称，就不提取了

最佳答案

月排行榜 / 总排行榜

冥王

2015-6-5 11:54

1. Sub Macro2()
   
2.     With ThisWorkbook
   
3.         '高级筛选
   
4.         .Sheets("提取转换表").Activate
   
5.         .Sheets("提取转换表").Cells.Clear
   
6.         .Sheets("费用").Range("A1").CurrentRegion.AdvancedFilter Action:=xlFilterCopy, _
   
7.                                                                CriteriaRange:=Sheets("主店").Range("A1").CurrentRegion, CopyToRange:=Range("A1")
   
8.         '乘以-1
   
9.         With .Sheets("提取转换表")
   
10.             .Cells(1, "X") = -1
    
11.             .Cells(1, "X").Copy
    
12.             .Range("A1").CurrentRegion.Select
    
13.             Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlMultiply
    
14.             .Cells(1, "X").Clear
    
15.             .Columns("A:U").AutoFit
    
16.         End With
    
17.     End With
    
18. End Sub

复制代码

跳转到最佳答案楼层

冥王

录制宏，高级筛选，筛选出的数据区域选择性粘贴，乘以-1，停止录制，结果就出来了，这是个流氓又偷懒的办法

冥王

1. Sub Macro2()
   
2.     With ThisWorkbook
   
3.         '高级筛选
   
4.         .Sheets("提取转换表").Activate
   
5.         .Sheets("提取转换表").Cells.Clear
   
6.         .Sheets("费用").Range("A1").CurrentRegion.AdvancedFilter Action:=xlFilterCopy, _
   
7.                                                                CriteriaRange:=Sheets("主店").Range("A1").CurrentRegion, CopyToRange:=Range("A1")
   
8.         '乘以-1
   
9.         With .Sheets("提取转换表")
   
10.             .Cells(1, "X") = -1
    
11.             .Cells(1, "X").Copy
    
12.             .Range("A1").CurrentRegion.Select
    
13.             Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlMultiply
    
14.             .Cells(1, "X").Clear
    
15.             .Columns("A:U").AutoFit
    
16.         End With
    
17.     End With
    
18. End Sub

复制代码

冥王

用数组写入，但是数据不带格式

1. Sub demo()
   
2.     Dim strTxt$, iRow%, i%, j%, arr, brr(1 To 50000, 1 To 20)
   
3.     With ThisWorkbook
   
4.         strTxt = Application.Phonetic(.Sheets("主店").Range("A2").CurrentRegion.Offset(1, 0))
   
5.         With .Sheets("费用")
   
6.             arr = .Range("A2:T" & .Cells(Rows.Count, 1).End(xlUp).Row)
   
7.             For i = LBound(arr, 1) To UBound(arr, 1)
   
8.                 If InStr(strTxt, arr(i, 1)) Then
   
9.                     iRow = iRow + 1
   
10.                     brr(iRow, 1) = arr(i, 1)
    
11.                     For j = 2 To 20
    
12.                         brr(iRow, j) = -arr(i, j)
    
13.                     Next
    
14.                 End If
    
15.             Next
    
16.         End With
    
17.         .Sheets("提取转换表").Range("A1").CurrentRegion.Offset(1, 0).Clear
    
18.         .Sheets("提取转换表").Range("A2").Resize(iRow, 20) = brr
    
19.     End With
    
20. End Sub

复制代码