Excel2019宏的应用之表格合并-中标数据处理

62 阅读 0 评论 41 点赞

我是靠谱客的博主灵巧星月，最近开发中收集的这篇文章主要介绍Excel2019宏的应用之表格合并-中标数据处理，觉得挺不错的，现在分享给大家，希望可以做个参考。

概述

Excel2019

Sub 中标数据处理()
Dim rng As Range, sht As Worksheet
Start = Timer
'新建一个工作表，名称为：be_yaopinzhongbiao
Worksheets.Add.Name = "be_yaopinzhongbiao"
'填写字段
[A1] = "me_uid"
[B1] = "me_name"
[c1] = "me_brandname"
[D1] = "me_jixing"
[E1] = "me_guige"
[F1] = "me_guifanguige"
[G1] = "me_baozhuanguige"
[H1] = "me_baozhuanguige2"
[I1] = "me_packaging"
[J1] = "me_feiyong"
[K1] = "me_categ"
[L1] = "me_status"
[M1] = "me_qlevel"
[n1] = "me_shengchanqiye"
[O1] = "me_bidder"
[P1] = "me_first"
[Q1] = "me_firstyingwen"
[r1] = "me_approvaldate"
[S1] = "me_remarks1"
[T1] = "me_remarks2"
[U1] = "me_source"
[v1] = "me_down"
[W1] = "me_remarks3"
'循环工作表，当名称不等于be_yaopinzhongbiao时进行判断和复制，粘贴到be_yaopinzhongbiao表对应位置
For Each sht In Sheets
    If sht.Name <> "be_yaopinzhongbiao" Then
    '获取使用区域的最大行号
    For Each rng In sht.Range("A1:W1")
        If rng = "me_name" Then
        cl = rng.Column
        Exit For '退出当前循环（可省）
        End If
    Next
    i = sht.Cells(Rows.Count, cl).End(xlUp).Row '原表中行号
    hi = Sheets("be_yaopinzhongbiao").Range("B" & Rows.Count).End(xlUp).Row
    '判断对应列
    For Each rng In sht.Range("A1:W1")
        '复制药品通用名
        If rng = "me_name" Then
            rng.Offset(2, 0).Resize(i - 2, 1).Copy Sheets("be_yaopinzhongbiao").Range("B" & hi + 1)
        End If
        '复制商品名
        If rng = "me_brandname" Then
            rng.Offset(2, 0).Resize(i - 2, 1).Copy Sheets("be_yaopinzhongbiao").Range("C" & hi + 1)
        End If
        '复制剂型
        If rng = "me_jixing" Then
            rng.Offset(2, 0).Resize(i - 2, 1).Copy Sheets("be_yaopinzhongbiao").Range("D" & hi + 1)
        End If
        '复制规格
        If rng = "me_guige" Then
            rng.Offset(2, 0).Resize(i - 2, 1).Copy Sheets("be_yaopinzhongbiao").Range("E" & hi + 1)
        End If
        '复制规范规格
        If rng = "me_guifanguige" Then
            rng.Offset(2, 0).Resize(i - 2, 1).Copy Sheets("be_yaopinzhongbiao").Range("F" & hi + 1)
        End If
        '复制包装转换比
        If rng = "me_baozhuanguige" Then
            rng.Offset(2, 0).Resize(i - 2, 1).Copy Sheets("be_yaopinzhongbiao").Range("G" & hi + 1)
        End If
        '复制规范包装转换比
        If rng = "me_baozhuanguige2" Then
            rng.Offset(2, 0).Resize(i - 2, 1).Copy Sheets("be_yaopinzhongbiao").Range("H" & hi + 1)
        End If
        '复制单位
        If rng = "me_packaging" Then
            rng.Offset(2, 0).Resize(i - 2, 1).Copy Sheets("be_yaopinzhongbiao").Range("I" & hi + 1)
        End If
        '复制中标价
        If rng = "me_feiyong" Then
            rng.Offset(2, 0).Resize(i - 2, 1).Copy Sheets("be_yaopinzhongbiao").Range("J" & hi + 1)
        End If
        '复制分类
        If rng = "me_categ" Then
            rng.Offset(2, 0).Resize(i - 2, 1).Copy Sheets("be_yaopinzhongbiao").Range("K" & hi + 1)
        End If
        '复制状态
        If rng = "me_status" Then
            rng.Offset(2, 0).Resize(i - 2, 1).Copy Sheets("be_yaopinzhongbiao").Range("L" & hi + 1)
        End If
        '复制质量层次
        If rng = "me_qlevel" Then
            rng.Offset(2, 0).Resize(i - 2, 1).Copy Sheets("be_yaopinzhongbiao").Range("M" & hi + 1)
        End If
        '复制生产企业
        If rng = "me_shengchanqiye" Then
            rng.Offset(2, 0).Resize(i - 2, 1).Copy Sheets("be_yaopinzhongbiao").Range("N" & hi + 1)
        End If
        '复制投标企业
        If rng = "me_bidder" Then
            rng.Offset(2, 0).Resize(i - 2, 1).Copy Sheets("be_yaopinzhongbiao").Range("O" & hi + 1)
        End If
        '复制省份
        If rng = "me_first" Then
            rng.Offset(2, 0).Resize(i - 2, 1).Copy Sheets("be_yaopinzhongbiao").Range("P" & hi + 1)
        End If
        '复制英省份名
        If rng = "me_firstyingwen" Then
            rng.Offset(2, 0).Resize(i - 2, 1).Copy Sheets("be_yaopinzhongbiao").Range("Q" & hi + 1)
        End If
        '复制发布日期
        If rng = "me_approvaldate" Then
            rng.Offset(2, 0).Resize(i - 2, 1).Copy Sheets("be_yaopinzhongbiao").Range("R" & hi + 1)
        End If
        '复制备注1
        If rng = "me_remarks1" Then
            rng.Offset(2, 0).Resize(i - 2, 1).Copy Sheets("be_yaopinzhongbiao").Range("S" & hi + 1)
        End If
        '复制备注2
        If rng = "me_remarks2" Then
            rng.Offset(2, 0).Resize(i - 2, 1).Copy Sheets("be_yaopinzhongbiao").Range("T" & hi + 1)
        End If
        '复制来源文件
        If rng = "me_source" Then
            rng.Offset(2, 0).Resize(i - 2, 1).Copy Sheets("be_yaopinzhongbiao").Range("U" & hi + 1)
        End If
        '复制链接
        If rng = "me_down" Then
            rng.Offset(2, 0).Resize(i - 2, 1).Copy Sheets("be_yaopinzhongbiao").Range("V" & hi + 1)
        End If
        '复制备注3
        If rng = "me_remarks3" Then
            rng.Offset(2, 0).Resize(i - 2, 1).Copy Sheets("be_yaopinzhongbiao").Range("W" & hi + 1)
        End If
        
        
        '工作表名
        [x1] = "me_sheet"
        Sheets("be_yaopinzhongbiao").Range("x" & hi + 1).Resize(i - 2, 1) = sht.Name
    Next
    
    End If
Next
    '设置字体字号格式
    With Sheets("be_yaopinzhongbiao").Cells.Font
        .Name = "等线"
        .Size = 11
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .ThemeFont = xlThemeFontMinor
    End With
    '边框和底纹
    With Sheets("be_yaopinzhongbiao").Cells.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Sheets("be_yaopinzhongbiao").Cells.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    
    
    With Sheets("be_yaopinzhongbiao").Cells.Interior
        .Pattern = xlNone
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With


MsgBox ("处理完毕！用时" & Format(Timer - Start, "0.00") & "秒")
End Sub

Sub 新中标数据处理()
Dim rng As Range, sht As Worksheet
Start = Timer
'新建一个工作表，名称为：be_yaopinzhongbiao
Worksheets.Add.Name = "be_yaopinzhongbiao"
'填写字段
[A1] = "me_uid"
[B1] = "me_name"
[c1] = "me_brandname"
[D1] = "me_jixing"
[E1] = "me_guige"
[F1] = "me_guifanguige"
[G1] = "me_baozhuanguige"
[H1] = "me_baozhuanguige2"
[I1] = "me_packaging"
[J1] = "me_feiyong"
[K1] = "me_categ"
[L1] = "me_status"
[M1] = "me_qlevel"
[n1] = "me_shengchanqiye"
[O1] = "me_bidder"
[P1] = "me_first"
[Q1] = "me_firstyingwen"
[r1] = "me_approvaldate"
[S1] = "me_remarks1"
[T1] = "me_remarks2"
[U1] = "me_source"
[v1] = "me_down"
[W1] = "me_remarks3"
'循环工作表，当名称不等于be_yaopinzhongbiao时进行判断和复制，粘贴到be_yaopinzhongbiao表对应位置
For Each sht In Sheets
    If sht.Name <> "be_yaopinzhongbiao" Then
    '获取使用区域的最大行号
    For Each rng In sht.Range("A1:W1")
        If rng = "me_name" Then
        cl = rng.Column
        Exit For '退出当前循环（可省）
    End If
Next
    i = sht.Cells(Rows.Count, cl).End(xlUp).Row '原表中行号
    hi = Sheets("be_yaopinzhongbiao").Range("B" & Rows.Count).End(xlUp).Row
    '判断对应列
    For Each rng In sht.Range("A1:W1")
    
        Select Case rng
        '复制药品通用名
        Case "me_name"
            rng.Offset(2, 0).Resize(i - 2, 1).Copy Sheets("be_yaopinzhongbiao").Range("B" & hi + 1)
        
        '复制商品名
        Case "me_brandname"
            rng.Offset(2, 0).Resize(i - 2, 1).Copy Sheets("be_yaopinzhongbiao").Range("C" & hi + 1)
        
        '复制剂型
        Case "me_jixing"
            rng.Offset(2, 0).Resize(i - 2, 1).Copy Sheets("be_yaopinzhongbiao").Range("D" & hi + 1)
        
        '复制规格
        Case "me_guige"
            rng.Offset(2, 0).Resize(i - 2, 1).Copy Sheets("be_yaopinzhongbiao").Range("E" & hi + 1)
        
        '复制规范规格
        Case "me_guifanguige"
            rng.Offset(2, 0).Resize(i - 2, 1).Copy Sheets("be_yaopinzhongbiao").Range("F" & hi + 1)
        
        '复制包装转换比
        Case "me_baozhuanguige"
            rng.Offset(2, 0).Resize(i - 2, 1).Copy Sheets("be_yaopinzhongbiao").Range("G" & hi + 1)
        
        '复制规范包装转换比
        Case "me_baozhuanguige2"
            rng.Offset(2, 0).Resize(i - 2, 1).Copy Sheets("be_yaopinzhongbiao").Range("H" & hi + 1)
        
        '复制单位
        Case "me_packaging"
            rng.Offset(2, 0).Resize(i - 2, 1).Copy Sheets("be_yaopinzhongbiao").Range("I" & hi + 1)
        
        '复制中标价
        Case "me_feiyong"
            rng.Offset(2, 0).Resize(i - 2, 1).Copy Sheets("be_yaopinzhongbiao").Range("J" & hi + 1)
        
        '复制分类
        Case "me_categ"
            rng.Offset(2, 0).Resize(i - 2, 1).Copy Sheets("be_yaopinzhongbiao").Range("K" & hi + 1)
        
        '复制状态
        Case "me_status"
            rng.Offset(2, 0).Resize(i - 2, 1).Copy Sheets("be_yaopinzhongbiao").Range("L" & hi + 1)
        
        '复制质量层次
        Case "me_qlevel"
            rng.Offset(2, 0).Resize(i - 2, 1).Copy Sheets("be_yaopinzhongbiao").Range("M" & hi + 1)
        
        '复制生产企业
        Case "me_shengchanqiye"
            rng.Offset(2, 0).Resize(i - 2, 1).Copy Sheets("be_yaopinzhongbiao").Range("N" & hi + 1)
        
        '复制投标企业
        Case "me_bidder"
            rng.Offset(2, 0).Resize(i - 2, 1).Copy Sheets("be_yaopinzhongbiao").Range("O" & hi + 1)
        
        '复制省份
        Case "me_first"
            rng.Offset(2, 0).Resize(i - 2, 1).Copy Sheets("be_yaopinzhongbiao").Range("P" & hi + 1)
        
        '复制英省份名
        Case "me_firstyingwen"
            rng.Offset(2, 0).Resize(i - 2, 1).Copy Sheets("be_yaopinzhongbiao").Range("Q" & hi + 1)
        
        '复制发布日期
        Case "me_approvaldate"
            rng.Offset(2, 0).Resize(i - 2, 1).Copy Sheets("be_yaopinzhongbiao").Range("R" & hi + 1)
        
        '复制备注1
        Case "me_remarks1"
            rng.Offset(2, 0).Resize(i - 2, 1).Copy Sheets("be_yaopinzhongbiao").Range("S" & hi + 1)
        
        '复制备注2
        Case "me_remarks2"
            rng.Offset(2, 0).Resize(i - 2, 1).Copy Sheets("be_yaopinzhongbiao").Range("T" & hi + 1)
        
        '复制来源文件
        Case "me_source"
            rng.Offset(2, 0).Resize(i - 2, 1).Copy Sheets("be_yaopinzhongbiao").Range("U" & hi + 1)
        
        '复制链接
        Case "me_down"
            rng.Offset(2, 0).Resize(i - 2, 1).Copy Sheets("be_yaopinzhongbiao").Range("V" & hi + 1)
        
        '复制备注3
        Case "me_remarks3"
            rng.Offset(2, 0).Resize(i - 2, 1).Copy Sheets("be_yaopinzhongbiao").Range("W" & hi + 1)
        
        
        
        '工作表名
        [x1] = "工作表名"
        Sheets("be_yaopinzhongbiao").Range("x" & hi + 1).Resize(i - 2, 1) = sht.Name
        
        End Select
    Next
    End If
Next

    '设置字体字号格式
    With Sheets("be_yaopinzhongbiao").Cells.Font
        .Name = "等线"
        .Size = 11
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .ThemeFont = xlThemeFontMinor
    End With
    '边框和底纹
    With Sheets("be_yaopinzhongbiao").Cells.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Sheets("be_yaopinzhongbiao").Cells.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    
    
    With Sheets("be_yaopinzhongbiao").Cells.Interior
        .Pattern = xlNone
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With


MsgBox ("处理完毕！用时" & Format(Timer - Start, "0.00") & "秒")
End Sub