VBA批量提取数据到Excel

Script_Man

已于 2023-12-21 20:27:53 修改

阅读量1.2k

点赞数 25

分类专栏： VBA进阶文章标签： excel 学习方法经验分享 windows 低代码

于 2023-12-15 16:52:39 首次发布

本文链接：https://blog.csdn.net/m0_62872215/article/details/135020092

版权

VBA进阶专栏收录该内容

14 篇文章 4 订阅

订阅专栏

Excel在处理大量的数据时，会频繁对单元格进行重复的操作，而VBA正好在处理重复单元格操作时具有显著的优势，因此运用VBA代码完成excel表格间数据的处理就很有用，处理数据的第一步往往是将原始数据初步整理成待分析的数据。

Case：将A,B的原始数据从对应的文件夹中读取出来，并筛选其中符合条件的数据复制到指定单元格，最后将两者的数据导入到待数据分析的单元格中。

具体完成方式可以参考流程图。


'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''主程序部分的代码
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub Sumb()
	Dim Bookfile as string, FinalFilePath as string
	Dim shRaw as Worksheet

    Bookfile = ThisWorkbook.Name
    Set shRaw = Workbooks(Bookfile).Sheets("raw")
    
	With shRaw
    .Columns("B:G").ClearContents   '批量清除单元格内容
    .Columns("I:N").ClearContents
    .Columns("P:U").ClearContents
    End with
    
    Call A_Input  'Call调用子程序
    Call C_Input
    Call Raw_data_transfer
        
    FinalFilePath = "D:\Data-Transfer\Raw-Data\Lite\"
    
    If Dir(FinalFilePath, vbDirectory) = "" Then   '判断目标文件夹是否存在，若不存在则创建该文件夹
        MkDir FinalFilePath
        Else
    End If
    
    ChDir FinalFilePath
    ActiveWorkbook.SaveAs Filename:=FinalFilePath & "\" & "New Data Check.xlsm"   '处理完成的表格另存在指定路径下
End Sub

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''将原始数据A复制到指定单元格中的子程序代码
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Sub A_Input()
	Dim Bookfile as string, FinalFilePath as string,Openfilename as string
	Dim shRaw as Worksheet
	
    Bookfile = ThisWorkbook.Name
    
    Set shRaw = Workbooks(Bookfile).Sheets("raw")
    FilePath = "D:\FTP\Map\LAX\KKK\"
   
    ChDrive "D"
    ChDir FilePath
        
    Openfilename = Application.GetOpenFilename("raw files (*.csv), *.csv")
         
    If Openfilename = False Then
        Exit Sub
        Else
    End If
    
    Check_name = Split(Openfilename, "\")   'Split方法拆分字符串
    Max_name = UBound(Check_name)           'Ubound获取字符串拆分后的最大下标
    Rawfilename = Check_name(Max_name)      '获取拆分后的最后一个字符串
        
        Workbooks.Open Filename:=Rawfilename   '打开工作表
        Columns("B:G").Copy destination:=shRaw.range("B1")   '复制数据到指定路径
        Application.CutCopyMode = False
        
        shRaw.Cells(1, 2) = Check_name(UBound(Check_name) - 2)  
        Workbooks(Rawfilename).Close 0   '关闭工作表，0表示不保存，也可以写成False

End Sub
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''将原始数据B复制到指定单元格中的子程序代码(注释部分同上)
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub B_Input()
	Dim Bookfile as string, FinalFilePath as string,Openfilename as string
	Dim shRaw as Worksheet

    Bookfile = ThisWorkbook.Name
    Set shRaw = Workbooks(Bookfile).Sheets("raw")
    
    FilePath = "F:\FTP\Map\LCX\k7\"
   
    ChDrive "F"
    ChDir FilePath
        
    Openfilename = Application.GetOpenFilename("raw files (*.csv), *.csv")
         
    If Openfilename = False Then
        Exit Sub
        Else
    End If
    
    Check_name = Split(Openfilename, "\")
    Max_name = UBound(Check_name)
    Rawfilename = Check_name(Max_name)
        
        Workbooks.Open Filename:=Rawfilename

        Workbooks.Open Filename:=Rawfilename
        Columns("B:G").Copy destination:=shRaw.range("P1")
        Application.CutCopyMode = False
        shRaw.Cells(1, 16) = Check_name(UBound(Check_name) - 2)
        
        Workbooks(Rawfilename).Close 0
End Sub

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''对原始数据进行筛选，并将筛选后的数据导入到待分析单元格的子程序代码
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub Transfer()
	Dim shRaw as Worksheet
	On Error Resume Next   '忽略代码的错误继续运行下去
	Application.ScreenUpdating = FALSE   '禁止代码运行时屏幕刷新，可缩短代码运行时间
    Set shRaw = Workbooks(Bookfile).Sheets("raw")

    With sheets("Transfer")
    .Columns("B:H").ClearContents
    .Columns("J:P")..ClearContents
    .Columns("R:X")..ClearContents
    End with

    ShRaw.Select
    ShRaw.Cells.AutoFilter Filed:=3,Criterial:="X"  '筛选3列字段是"X"的数据
	ShRaw.Range("B:B,D:D,G:G").Copy Destination:=Sheets("Transfer").range("B:D")   '将表格Raw中的B,D,G三列数据复制到表格Transfer B至D列。
	
    ShRaw.Cells.AutoFilter Filed:=3,Criterial:="Y"   筛选3列字段是"Y"的数据
	ShRaw.Range("D:D,G:G").Copy destination:=Sheets("Transfer").range("E1")   '将表格Raw中的D,G两列数据复制到表格Transfer以E1为起始单元格的位置。
	
    ShRaw.Cells.AutoFilter Filed:=3,Criterial:="Circle"   '筛选3列字段是"X"的数据
	ShRaw.Range("D:D,G:G").Copy Destination:=Sheets("Transfer").range("G1")   '将表格Raw中的D,G两列数据复制到表格Transfer以G1为起始单元格的位置。
    Selection.AutoFilter   '取消筛选

    Application.Wait(10)   '等待10ms再运行，防止单元格操作太快产生卡顿
    ShRaw.Cells.AutoFilter Filed:=3,Criterial:="X"
	ShRaw.Range("I:I,K:K,N:N").Copy Destination:=Sheets("Transfer").Columns("J:J").Range("A1")
	
    ShRaw.Cells.AutoFilter Filed:=3,Criterial:="Y"
	ShRaw.Range("K:K,N:N").Copy destination:=Sheets("Transfer").Columns("M:M").Range("A1")
	
    ShRaw.Cells.AutoFilter Filed:=3,Criterial:="Circle"
	ShRaw.Range("K:K,N:N").Copy Destination:=Sheets("Transfer").Columns("O:O").Range("A1")
    Selection.AutoFilter
    
    Sheets("Analysis").Range("A:X").ClearContents
    Sheets("Transfer").Range("A:X").Copy Destination:=Sheets("Analysis").Columns("A:A").Range("A1")
    
    Application.ScreenUpdating = True  '允许代码运行时屏幕刷新，与前面禁止成对存在
End Sub