09月22日, 2014 1852次
Sub opgo() '-------------- 指定列配置定区域--------------------- Dim xiaoshouelie, maolielie, maolilvlie, xiaoshouebiaoshi, maoliebiaoshi, maolilvbiaoshi, paixuquyu paixuquyu_begin = "A" '参与排序最小列 paixuquyu_end = "G" '参与排启最大列 xiaoshouelie = "B" '销售额列 maolielie = "C" '毛利额列 maolilvlie = "D" '毛利率列 xiaoshouebiaoshi = "E" '销售额标识 maoliebiaoshi = "F" '毛利额标识 " maolilvbiaoshi = "G" ' 毛利率标识 huizongbiaoshi = "H" '汇总标识 '--------------- 初始信息获取------------------------- 'maxrow = Cells(Rows.Count, s).End(xlUp).Row 'maxrow = Cells(Rows.Count, "a").End(xlUp).Row 'Range(s & "2:" & s & i).ClearContents Set sht = ActiveWorkbook.Sheets("sheet1") sht.Activate maxrow = sht.UsedRange.Rows.Count '获取当前表最大行数 Range(xiaoshouebiaoshi & "2:" & xiaoshouebiaoshi & maxrow).ClearContents Range(maoliebiaoshi & "2:" & maoliebiaoshi & maxrow).ClearContents Range(maolilvbiaoshi & "2:" & maolilvbiaoshi & maxrow).ClearContents Range(huizongbiaoshi & "2:" & huizongbiaoshi & maxrow).ClearContents '激活当前工作表,Sort只能排序当前工作表 '--------------- 删除无效行------------------------------------------------------------------------------------------------------------ For i = 2 To maxrow '删除销售额为0或者为空的行 Dim xiaoshoue xiaoshoue = Range(xiaoshouelie & i).Value If (xiaoshoue = 0 Or xiaoshoue = "") Then MsgBox "删除行:" & i Rows(i).Delete End If Next maxrow = sht.UsedRange.Rows.Count '删除后重新获取当前表最大行数 '-------------- 按销售额排序------------------------------------------------------------ ----------- --------------------- 'sht.Range("A2:m" & maxRow).Sort key1:=sht.Range("B2"), order1:=xlDescending, Header:=xlNo quyu = paixuquyu_begin & "2:" & paixuquyu_end & maxrow Key = xiaoshouelie & "2" sht.Range(quyu).Sort key1:=sht.Range(Key), order1:=xlDescending, Header:=xlNo 'sht.Range(quyu).Sort keyl:=sht.Range(Key), order1:=xlDescending, Header:=xlNo Dim zongxiaoshoujine zongxiaoshoujine = Application.WorksheetFunction.Sum(Columns(get_number(xiaoshouelie))) '获取所有销售金额 'Range("jl") = zongxi aoshouj ine J Application. Sum(Columns(1)) J zongxiaoshoujine For i = 2 To maxrow Dim zhanbi, zhanbileiji '占比占比累计 zhanbi = Range(xiaoshouelie & i).Value / zongxiaoshoujine If i = 2 Then zhanbileiji = zhanbi Else zhanbileiji = zhanbileiji + zhanbi End If 'Range("k" & i) = zhanbi 'Range。]." & i) = zhanbileiji If (zhanbileiji < 0.7999) Then Range(xiaoshouebiaoshi & i) = "A" ElseIf (zhanbileiji < 0.9499) Then Range(xiaoshouebiaoshi & i) = "B" Else Range(xiaoshouebiaoshi & i) = "C" End If Next '----------------- 按毛利额排序----------------------------------------------------------------------------------------------------------- quyu = paixuquyu_begin & "2:" & paixuquyu_end & maxrow Key = maolielie & "2" sht.Range(quyu).Sort key1:=sht.Range(Key), order1:=xlDescending, Header:=xlNo 'sht.Range(paixuquyu_begin & "2:" & paixuquyu_end & maxRow).Sort keyl:=sht.Range(maolielie & "2"), order1:=xlDescending, Header:=xlNo Dim zongmaolijine zongmaolijine = Application.WorksheetFunction.Sum(Columns(get_number(maolielie))) '获取所有毛利额累加 For i = 2 To maxrow Dim zhanbi2, zhanbileiji2 '占比占比累计 zhanbi2 = Range(maolielie & i).Value / zongmaolijine If i = 2 Then zhanbileiji2 = zhanbi2 Else zhanbileiji2 = zhanbileiji2 + zhanbi2 End If 'Range("k" & i) = zhanbi2 ' Range("1" & i) = zhanbileiji2 If (zhanbileiji2 < 0.7999) Then Range(maoliebiaoshi & i) = "A" ElseIf (zhanbileiji2 < 0.9499) Then Range(maoliebiaoshi & i) = "B" Else Range(maoliebiaoshi & i) = "C" End If Next '__ --------------------处理毛利率----------------------------------------------------------------------------------------------------- For i = 2 To maxrow Dim maolilv maolilv = Range(maolilvlie & i).Value If (maolilv > 0.5) Then Range(maolilvbiaoshi & i) = "A" Else Range(maolilvbiaoshi & i) = "" End If Range(huizongbiaoshi & i) = Range(xiaoshouebiaoshi & i).Value & Range(maoliebiaoshi & i).Value & Range(maolilvbiaoshi & i).Value '合并汇总 Next MsgBox "分析结束!" ActiveWorkbook.Save End Sub Function get_number(letter) '根据列字母得到第几列 Dim letterl letterl = Asc(UCase(letter)) get_number = (letterl - 64) End Function
暂无留言,赶快评论吧