全民一起VBA实战篇第三课：文本内容的实用技巧

最新推荐文章于 2020-02-27 16:18:08 发布

高开低走。

最新推荐文章于 2020-02-27 16:18:08 发布

阅读量516

点赞数

分类专栏：锦到说VBA

本文链接：https://blog.csdn.net/qq_43568982/article/details/104109993

版权

锦到说VBA 专栏收录该内容

37 篇文章 24 订阅

订阅专栏

题目一

题目要求：
要求大家编写程序自动在F列中标记出每一个交易记录是该客户的第几次交易。比如第3行的“赵六”是第一次出现，所以F3为 1 ，而第4行的“赵六”是第二次出现，所以F4应为 2 。

方法一：
双重循环

Option Explicit
Sub demo()
    Dim i As Long, j As Long, s As Long
    Dim r As Object
    Set r = Application.ActiveSheet.UsedRange
    For i = 3 To r.Rows.count + r.Row - 1   
        If Cells(i, 6) = "" Then           
            s = 1
            Cells(i, 6) = s
        '标记第一次出现
            For j = i + 1 To r.Rows.count + r.Row - 1                
                If Cells(j, 3) = Cells(i, 3) Then
                '如果出现重复，就标记+1
                '先扫描完所有符合当前字段的，一一标记
                    s = s + 1
                    Cells(j, 6) = s
                End If
            Next j        
        End If        
    Next i
End Sub

方法二：
字典

Sub 字典demo2()
	Dim dic As Object, r As Range, k, i
	Set dic = CreateObject("scripting.dictionary")
	'创建字典对象
    For i = 3 To 23
        k = Cells(i, 3).Value
        dic(k) = dic(k) + 1
        '如果字典中已经有了姓名k，则取出数值并加1，再写会该条目
        '如果尚无k，则添加此姓名，并设置数值为空白+1
        Cells(i, 8) = dic(k)
    Next i
End Sub

题目二

题目要求：
按照GDP大小进行降序排列
在这里插入图片描述

使用冒泡排序
先给出C语言描述的冒泡排序作为参考

#include <stdio.h>
 
#define ARR_LEN 255 /*数组长度上限*/
#define elemType int /*元素类型*/
 
/* 冒泡排序 */
/* 1. 从当前元素起，向后依次比较每一对相邻元素，若逆序则交换 */
/* 2. 对所有元素均重复以上步骤，直至最后一个元素 */
/* elemType arr[]: 排序目标数组; int len: 元素个数 */
void bubbleSort (elemType arr[], int len) 
{
    elemType temp;
    int i, j;
    for (i=0; i<len-1; i++) /* 外循环为排序趟数，len个数进行len-1趟 */
        for (j=0; j<len-1-i; j++) { /* 内循环为每趟比较的次数，第i趟比较len-i次 */
            if (arr[j] > arr[j+1]) { /* 相邻元素比较，若逆序则交换（升序为左大于右，降序反之） */
                temp = arr[j];
                arr[j] = arr[j+1];
                arr[j+1] = temp;
            }
        }
}
 
int main (void) 
{
    elemType arr[ARR_LEN] = {3,5,1,-7,4,9,-6,8,10,4};
    int len = 10;
    int i;
     
    bubbleSort (arr, len);
    for (i=0; i<len; i++)
        printf ("%d\t", arr[i]);
    putchar ('\n');
     
    return 0;
}

再给出VBA代码

Sub 简单冒泡排序()
    Dim i, j As Long
    For i = 3 To 23
    '第一个参与排序的数据位于第三行，数据总共20个
        For j = 3 To 26 - i
        '第一个参与数据的位置时第三列
        '一直需要遍历到数据长度20加上起始位置3加上i的起始位置3
        '再减去i
            If cells(j, 3) < cells(j + 1, 3) Then
                cells(1, 2) = cells(j, 2)
                cells(j, 2) = cells(j + 1, 2)
                cells(j + 1, 2) = cells(1, 2)
                cells(1, 1) = cells(j, 3)
                cells(j, 3) = cells(j + 1, 3)
                cells(j + 1, 3) = cells(1, 1)
                '简单交换
            End If
        Next j
    Next i
    cells(1, 2) = ""
    cells(1, 1) = ""
    '清除中间变量
End Sub

但是要说一句，这种排序速度较慢，真正用还是用自带的函数比较好

题目三

使用Range.Sort方法，对2016年里约奥运会奖牌榜进行排序。排序规则为：主关键字是金牌数；如果金牌数相同则使用奖牌总数；如果奖牌总数也相同，则按国家名称的拼音顺序升序排列。

Sub 用sort()
    Dim r As Range
    Set r = ActiveSheet.UsedRange
    r.Sort key1:=Range("c3"), order1:=xlDescending, key2:=Range("d3"), order2:=xlDescending, SortMethod:=xlPinYin
    'sort后面不加括号
    '传参给冒号和等号
End Sub

Range.Sort(key1,order1,key2,order2,key3,order3,Header,MatchCase,Orientation,Sortmethod)

分别是主关键字，顺序方式，次关键字，顺序方式，第三关键字，顺序方式，Header是排序是否包括第一行抬头，Matchcase在于是否匹配大小写，Orientation可以用来行排序，SOrtmethod可以用来按拼音排序

还有，如果数字设置为了文本格式，那么排序按照字符串还是数字，可以进行设置
dataoptional:=xlnormal文本 44排在305后面
dataoptional:=xlsorttextasnumbers看成数字，44排在305前面

题目四

在这里插入图片描述

使用Range.Sort的自定义排序功能，按照左侧的百家姓规则，对所有十张表格的第二列“姓名”进行排序。
赵钱孙李周吴郑王冯陈褚卫蒋沈韩杨

Option Explicit
Sub myOrder()
   Dim w As Worksheet, i As Long
   Dim mylist()
    '将sheet3中的姓氏规则加入到Excel自定义序列中
    '注意如果Excel中已有相同的规则，那么本行语句会执行出错，需要先删除该规则。
    mylist = Array("赵", "钱", "孙", "李", "周", "吴", "郑", "王", "冯", "陈", "褚", "卫", "蒋", "沈", "韩", "杨")
    Application.AddCustomList mylist    
    For Each w In Worksheets   
        If w.Name <> "Sheet3" Then       
            '因为自定义排序必须“整单元格匹配”，所以先从工作表w中B列姓名里面取出“姓”（单字），并存入第一列以供排序使用。
            '如果实际工作中第一列或第三列已有数据、不能更改，可以用宏代码先插入一列，排序结束后再删除该列即可。
            i = 2
            Do While w.Cells(i, 2) <> ""
                w.Cells(i, 1) = Left(w.Cells(i, 2), 1)
                i = i + 1
            Loop
            '以第一列“姓”为关键字进行排序，排序后将该列清空以恢复表格原状。
            w.Range("a:b").Sort key1:=w.Range("a1"), ordercustom:=Application.CustomListCount + 1
            w.Range("a:a").Clear    
        End If    
    Next w
    Application.DeleteCustomList Application.CustomListCount
End Sub

题目五

统计出席人数
在10个worksheet中，统计出席人数汇总

Sub 字典加数组()
	Dim t
	t = Timer()
	Dim dic As Object, r As Range, k, i
	Dim w As Worksheet, wsum As Worksheet
	Dim a()
	Set dic = CreateObject("scripting.dictionary")
	'创建字典对象
	Set wsum = Worksheets("出席统计")	
	For Each w In Worksheets
	    If w.Name <> "出席统计" Then
	        a = w.UsedRange
	            For Each k In a
	                dic(k) = dic(k) + 1
	                '如果字典中已经有了姓名k，则取出数值并加1，再写会该条目
	                '如果尚无k，则添加此姓名，并设置数值为空白+1
	            Next k
	    End If
	Next w
	a = dic.Keys()
	wsum.Range("a2:a" & UBound(a) + 2) = Application.Transpose(a)
	a = dic.items()
	wsum.Range("b2:b" & UBound(a) + 2) = Application.Transpose(a)
	'利用数组赋值
	Worksheets("出席统计").UsedRange.Sort Key1:=Range("B1"), Order1:=xlDescending, Header:=xlYes
	MsgBox "一共用时" & Timer() - t & "秒"
End Sub

题目六

在这里插入图片描述
计算应交税

Sub 计算合并单元格()
Dim i As Long, r As Range
    For i = 3 To 14
        Set r = Cells(i, 5).MergeArea
        '取合并单元格
        Cells(i, 6) = Cells(i, 4) * r.Cells(1, 1).Value
        '取r中的第一个，.value保证取的值
    Next i    
End Sub

题目七

拆分合并单元格或者合并单元格
在这里插入图片描述

Sub 拆分单元格()
	Dim i As Long, k As Long
    For i = 3 To 14
        If Cells(i, 2).MergeCells = True Then
            k = Cells(i, 2).MergeArea.Rows.Count
            '记录合并单元格的行数
            Cells(i, 2).UnMerge
            '拆分
            Range(Cells(i, 2), Cells(i + k - 1, 2)).Value = Cells(i, 2).Value
            '拆分后空的部分都补齐
            i = i + k - 1
            '拆分下来的部分就不要二次扫描了
        End If
    Next i
End Sub

在这里插入图片描述

再合并回来

Sub 合并单元格()
	Dim i As Long, r As Range
	Application.DisplayAlerts = False
	'防止弹出警告对话框
    For i = 14 To 4 Step -1
        If Cells(i, 2) = Cells(i - 1, 2) Then
            Range(Cells(i, 2), Cells(i - 1, 2)).Merge
        End If
    Next i
	Application.DisplayAlerts = True
	'恢复弹出框
End Sub

在这里插入图片描述
一般情况下，如果是用于计算，尽量避免合并单元格，单独用于展示的数据另说

题目八

按照每个公司的合计计件量（比如甲公司的D5单元格数字），由大到小对四个公司进行排序。

在这里插入图片描述

Sub orderDemo()
    Dim i&, j&, iRows&, jRows&        
    '以下使用选择排序法思想对表格进行排序
    i = 2
    Do While i <= 13    
        '让 j 从i的下一个公司（即下一个合并区域的首行）开始循环
        j = i + Cells(i, 1).MergeArea.Rows.Count
        Do While j <= 13             
            '获得当前i、j两个公司的合并区域总行数
            iRows = Cells(i, 1).MergeArea.Rows.Count
            jRows = Cells(j, 1).MergeArea.Rows.Count           
            '如果j公司最后一行第3列(即合计)大于i公司，则将j剪切到i前面
            If Cells(j + jRows - 2, 3) > Cells(i + iRows - 2, 3) Then
                Cells(j, 1).Resize(jRows, 4).Cut
                Cells(i, 1).Insert Shift:=xlDown
            End If            
            '让j的增加值为当前合并区域的总行数，从而直接跳到下一个公司上
            j = j + jRows
        Loop        
         '让i的增加值为当前合并区域的总行数，从而直接跳到下一个公司上
        i = i + Cells(i, 1).MergeArea.Rows.Count
    Loop
End Sub