vba实践
1、查询满足条件的单元格行数 | 单元格汇总到本表
案例背景：
文件夹中有很多公司的每天市值信息，一张表格一家公司，有日期，当日市值等
查询某个日期的市值，并汇总到一张表格中
汇总表中有当日所有公司的市值信息
Sub 市值汇总表() Dim findDate As String Dim a As Integer findDate = "2018/8/15" a = 1 Application.ScreenUpdating = False myfile = Dir(ThisWorkbook.Path & "\*.xls*") ThisWorkbook.Worksheets(1).Cells(1, 1) = "文件名称" ThisWorkbook.Worksheets(1).Cells(1, 2) = "简称" ThisWorkbook.Worksheets(1).Cells(1, 3) = findDate & "市值" Do While myfile <> "" If myfile <> ThisWorkbook.Name Then Set wb = Workbooks.Open(ThisWorkbook.Path & "\" & myfile) a = a + 1 Set aftersheet = wb.ActiveSheet.Range("C:C") aftersheet.NumberFormat = "yyyy/m/d" Set findRange = aftersheet.Find(DateValue(findDate)) ThisWorkbook.Worksheets(1).Cells(a, 1) = myfile '文件名称即代码 ThisWorkbook.Worksheets(1).Cells(a, 2) = wb.ActiveSheet.Range("b2") '公司简称 If Not findRange Is Nothing Then ThisWorkbook.Worksheets(1).Cells(a, 3) = wb.ActiveSheet.Range("N" & findRange.Row) '当日市值 Else ThisWorkbook.Worksheets(1).Cells(a, 3) = "无当日市值" '当日市值 End If wb.Close False End If myfile = Dir Loop Application.ScreenUpdating = True MsgBox "完成" End Sub
2、复制每个excel第二行并汇总
案例背景：
基本情况同一
此处需要汇总所有excel第二行的信息，即每家公司的开市情况
汇总表中是所有公司的开市情况
Sub 第二行汇总() Dim findDate As String Dim a As Integer findDate = "2018/8/15" a = 1 Application.ScreenUpdating = False myfile = Dir(ThisWorkbook.Path & "\*.xls*") Do While myfile <> "" If myfile <> ThisWorkbook.Name Then Set wb = Workbooks.Open(ThisWorkbook.Path & "\" & myfile) a = a + 1 wb.ActiveSheet.Rows(2).Copy wb.Close False End If myfile = Dir Loop Application.ScreenUpdating = True MsgBox "完成" End Sub
Sub test() Dim mainRowNo As Integer Dim days As Long Dim startdaterowno As Long Dim totalrow As Long Dim activeEnd As Long Dim Start, endDate, startno, enddateno, wb days = 120 Application.ScreenUpdating = False myfile = Dir(ThisWorkbook.Path & "\*.xls*") Do While myfile <> "" If myfile = "" Then Exit Do End If If myfile <> ThisWorkbook.Name Then Set wb = Workbooks.Open(ThisWorkbook.Path & "\" & myfile) For mainRowNo = 3 To 48 wb.Sheets(1).Activate Start = ThisWorkbook.ActiveSheet.Range("E" & mainRowNo) '开始日期 endDate = ThisWorkbook.ActiveSheet.Range("o" & mainRowNo) '结束日期 'Start.NumberFormat = "yyyy/m/d" 'EndDate.NumberFormat = "yyyy/m/d" Set aftersheet = wb.ActiveSheet.Range("c:c") aftersheet.NumberFormat = "yyyy/m/d" Set startno = aftersheet.Find(DateValue(Start)) '开始日期的位置 Set enddateno = aftersheet.Find(DateValue(endDate)) '结束日期的位置 If Not startno Is Nothing Then If Not enddateno Is Nothing Then startdaterowno = startno.Row - days '往前推120天的位置 totalrow = enddateno.Row - startdaterowno wb.Sheets.Add after:=ActiveSheet ActiveSheet.Name = mainRowNo - 2 activeEnd = totalrow + 1 wb.ActiveSheet.Cells(1, 1) = "日期" wb.ActiveSheet.Cells(1, 2) = "涨跌幅" wb.Sheets(1).Range("c" & startdaterowno & ":c" & enddateno.Row).Copy Destination:=wb.ActiveSheet.Range("a2:a" & activeEnd) wb.Sheets(1).Range("l" & startdaterowno & ":l" & enddateno.Row).Copy Destination:=wb.ActiveSheet.Range("b2:b" & activeEnd) Else wb.Sheets.Add after:=ActiveSheet ActiveSheet.Name = mainRowNo - 2 wb.ActiveSheet.Cells(1, 1) = "日期" wb.ActiveSheet.Cells(1, 2) = "涨跌幅" wb.ActiveSheet.Range("a2:a140").Value = "无" wb.ActiveSheet.Range("b2:b140").Value = "无" End If Else wb.Sheets.Add after:=ActiveSheet ActiveSheet.Name = mainRowNo - 2 wb.ActiveSheet.Cells(1, 1) = "日期" wb.ActiveSheet.Cells(1, 2) = "涨跌幅" wb.ActiveSheet.Range("a2:a140").Value = "无" wb.ActiveSheet.Range("b2:b140").Value = "无" End If Next mainRowNo wb.Close True End If myfile = Dir '查找下一张表格 Loop Application.ScreenUpdating = True MsgBox "完成" End Sub
Sub test() Dim mainRowNo As Integer Dim col As Integer col = 1 Application.ScreenUpdating = False myfile = Dir(ThisWorkbook.Path & "\*.xls*") For mainRowNo = 1 To 46 ThisWorkbook.Sheets.Add ThisWorkbook.ActiveSheet.Name = mainRowNo Next mainRowNo Do While myfile <> "" If myfile = "" Then Exit Do End If col = col + 1 If myfile <> ThisWorkbook.Name Then Set wb = Workbooks.Open(ThisWorkbook.Path & "\" & myfile) For mainRowNo = 1 To 46 Set asheet = ThisWorkbook.Sheets(mainRowNo) Set wbsheet = wb.Sheets(mainRowNo + 1) 'ThisWorkbook.Sheets(mainRowNo).Columns(col).Value = wb.Sheets(mainRowNo + 1).Columns(2).Value 'asheet.Columns(col).Insert , CopyOrigin:=xlFormatFromRightOrBelow 'wb.Sheets(mainRowNo + 1).Columns(2).Copy Destination:=ThisWorkbook.Sheets(mainRowNo).Columns(col) wbsheet.Range(wbsheet.Cells(2, 2), wbsheet.Cells(140, 2)).Copy Destination:=asheet.Range(asheet.Cells(2, col), asheet.Cells(140, col)) asheet.Cells(1, col).Value = wb.Sheets(1).Range("b2").Value If col = 2 Then ThisWorkbook.Sheets(mainRowNo).Columns(1).Value = wb.Sheets(mainRowNo + 1).Columns(1).Value End If Next mainRowNo wb.Close Savechanges:=False End If myfile = Dir '查找下一张表格 Loop Application.ScreenUpdating = True MsgBox "完成" End Sub
Sub test() Dim mainRowNo As Integer Dim col As Integer col = 1 Application.ScreenUpdating = False myfile = Dir(ThisWorkbook.Path & "\*.xls*") Do While myfile <> "" If myfile = "" Then Exit Do End If col = col + 1 If myfile <> ThisWorkbook.Name Then Set wb = Workbooks.Open(ThisWorkbook.Path & "\" & myfile) For mainRowNo = 1 To 46 Set asheet = ThisWorkbook.Sheets(mainRowNo + 1) Set wbsheet = wb.Sheets(mainRowNo) wbsheet.Columns(2).Insert asheet.Range(asheet.Cells(2, 2), asheet.Cells(140, 2)).Copy Destination:=wbsheet.Range(wbsheet.Cells(2, 2), wbsheet.Cells(140, 2)) wbsheet.Cells(1, 2).Value = "上证指数" Next mainRowNo wb.Close Savechanges:=True End If myfile = Dir '查找下一张表格 Loop Application.ScreenUpdating = True MsgBox "完成" End Sub
去除sheet中连续10个0
Sub test() Dim count As Integer Dim tmp As Integer Dim columnsNo As Integer For i = 1 To 46 columnsNo = Sheets(i).UsedRange.Columns.count For j = 2 To columnsNo '循环列数 count = 0 tmp = 0 For k = 2 To 132 '循环行数，统计连续0的个数 If Sheets(i).Cells(k, j).Value = 0 Then tmp = tmp + 1 Else If tmp > count Then count = tmp End If tmp = 0 End If If tmp > count Then count = tmp End If Next k If count > 10 Then Sheets(i).Columns(j).Delete j = j - 1 columnsNo = Sheets(i).UsedRange.Columns.count End If If j = columnsNo Then Exit For End If Next j Next i MsgBox "完成" End Sub
去除含有无的
Sub test() Dim count As Integer Dim tmp As Integer Dim columnsNo As Integer For i = 1 To 46 columnsNo = Sheets(i).UsedRange.Columns.count For j = 2 To columnsNo '循环列数 count = 0 tmp = 0 For k = 2 To 132 '循环行数，统计连续0的个数 If Sheets(i).Cells(k, j).Value = "无" Then Sheets(i).Columns(j).Delete j = j - 1 columnsNo = Sheets(i).UsedRange.Columns.count End If Next k If j = columnsNo Then Exit For End If Next j Next i MsgBox "完成" End Sub
批量另存为csv文件
Sub SaveToCSVs() Dim fDir As String Dim wB As Workbook Dim wS As Worksheet Dim fPath As String Dim sPath As String fPath = "D:\workspace_trade\小艾同学\csrc事件\第四版（不同时间段数据汇总问题）\连续5个0\before\" sPath = "D:\workspace_trade\小艾同学\csrc事件\第四版（不同时间段数据汇总问题）\连续5个0\after\" test = ThisWorkbook.Path fDir = Dir(fPath) Do While (fDir <> "") If Right(fDir, 4) = ".xls" Or Right(fDir, 5) = ".xlsx" Then On Error Resume Next Set wB = Workbooks.Open(fPath & fDir) 'MsgBox (wB.Name) For Each wS In wB.Sheets wS.SaveAs sPath & wB.Name & ".csv", xlCSV Next wS wB.Close False Set wB = Nothing End If fDir = Dir On Error GoTo 0 Loop MsgBox "完成" End Sub
Sub SaveToCSVs() Dim fDir As String Dim wB As Workbook Dim wS As Worksheet Dim fPath As String Dim sPath As String '源文件地址 fPath = "C:\Users\pc\Desktop\" '目标文件地址 sPath = "C:\Users\pc\Desktop\" fDir = Dir(fPath) Do While (fDir <> "") If Right(fDir, 4) = ".xls" Or Right(fDir, 5) = ".xlsx" Then On Error Resume Next Set wB = Workbooks.Open(fPath & fDir) 'MsgBox (wB.Name) 'MsgBox (wS.Name) For Each wS In wB.Sheets wS.SaveAs sPath & wS.Name & ".csv", xlCSV Next wS wB.Close False Set wB = Nothing End If fDir = Dir On Error GoTo 0 Loop End Sub
