[已解决]现在是运行不了，请帮忙修改。谢谢了

nicehyx

源码如下
Sub testDays()
    Dim oldfile As Workbook
    Dim path As String
    Dim filename As String
    Dim tubiao As String
    Dim yuanshibiao As Range
    Dim tiaojianbiao As Range
    Dim copy As Range
    Dim xianyouziliao As Range
    Dim rngAll As Range         
    Dim rngA As Range            
    Dim dteStart As String        
    Dim dteEnd As String        
    Dim rowsCnt  As Long      
    Dim rngC As Range           
    Dim C As Range
    Dim d As Workbook



     Dim sh As Workbook
     filename = Application.GetOpenFilename(FileFilter:="excel 数据文件 (*.xlsm),*.xlsm", Title:="请选择文件")
     Set sh = Workbooks.Open(filename) '取生成新表的表单名,start

  
    sh.Sheets("sheet2").Cells.copy ActiveSheet.Cells(1, 1)    '将sheet1完全复制到当前表
   
   
    Set sh = Nothing
   
   
    Application.ScreenUpdating = ture     
    ActiveSheet.UsedRange.Offset(4).ClearContents   
   
    If [m1] > [m2] Then                                   
        MsgBox "开始日期要大于结束日期.", 64, "日期错误"
                                                                  
        Exit Sub                                             
    End If
   
    With Sheets("sheet2")                              
        Set rngAll = .UsedRange                    
        Set rngA = .Rows(1).SpecialCells(2) 'Data
        dteStart = ">=" & Range("M1")         
        dteEnd = "<=" & Range("M2")            
   
        rngAll.AutoFilter Field:=2, Criteria1:= _
            dteStart, Operator:=xlAnd, Criteria2:=dteEnd
                                                                  
        rowsCnt = .Columns("B").SpecialCells(2).SpecialCells(12).Count
                                                                    
        If rowsCnt = 1 Then                              
            MsgBox "数据导入错误.", 64, 数据倒入错误"
            GoTo noData                                 
        End If
        
        For Each rngC In Rows(4).SpecialCells(2)
            Set C = rngA.Find(rngC, , , xlWhole)
                rngAll.Offset(1).Columns(C.Column).SpecialCells(12).copy rngC.Offset(1)
        Next rngC                                             
        
    End With
   
noData:                                                         
    rngAll.AutoFilter                                         
   
    Set rngAll = Nothing                                 
    Set rngA = Nothing
    Set rngC = Nothing
End Sub

最佳答案

月排行榜 / 总排行榜

无聊的疯子

2013-6-8 14:40

nicehyx 发表于 2013-6-8 14:09
rowsCnt = .Columns("B").SpecialCells(2).SpecialCells(12).Count

rowsCnt = .Columns("B").SpecialCells(2).SpecialCells(12).Count

定位 B 列 含有常量的单元格，在这些单元格中定位 可见单元格 ，返回这些单元格的个数

该 代码在 new.xlsm 文件中，而你的代码提取的数据是放到 第一个工作表中的，
d.Sheets("sheet2").Cells.copy ThisWorkbook.Sheets(1).Range("A1")    '将
第二个表里什么数据都没有，当然会找不到了

这就是原因。。。

跳转到最佳答案楼层

无聊的疯子

只贴代码，不贴附件，也不说具体 那里不能运行。。。

好吧，找到了问题也和你一样“里面有一句代码没写对，改了就行了”

nicehyx

无聊的疯子 发表于 2013-6-8 13:46
只贴代码，不贴附件，也不说具体 那里不能运行。。。

好吧，找到了问题也和你一样“里面有一句代码没写对 ...

rowsCnt = .Columns("B").SpecialCells(2).SpecialCells(12).Count



附上文件
这句,说未找到单元格

无聊的疯子

nicehyx 发表于 2013-6-8 14:09
rowsCnt = .Columns("B").SpecialCells(2).SpecialCells(12).Count

rowsCnt = .Columns("B").SpecialCells(2).SpecialCells(12).Count

定位 B 列 含有常量的单元格，在这些单元格中定位 可见单元格 ，返回这些单元格的个数

该 代码在 new.xlsm 文件中，而你的代码提取的数据是放到 第一个工作表中的，
d.Sheets("sheet2").Cells.copy ThisWorkbook.Sheets(1).Range("A1")    '将
第二个表里什么数据都没有，当然会找不到了

这就是原因。。。

nicehyx

无聊的疯子 发表于 2013-6-8 14:40
rowsCnt = .Columns("B").SpecialCells(2).SpecialCells(12).Count

定位 B 列 含有常量的单元格，在这 ...

源代码需要怎么修改???请赐教..谢谢.好人啊!!

nicehyx

就差最后一点点了!~~~~


For Each rngC In Rows(4).SpecialCells(2)