[已解决]求助：VBA在海量药品中，提取需要的药品

grf1973

考虑了格式，没考虑一开始的选择范围。

huizhiaisha

yjwdjfqb 发表于 2014-10-7 12:49
哦，只要内容一样就行了，谢谢老师！
我再核对下数据，非常的感谢！

邮件发你了，你看一下

有两种

一种是公式做的
一种是VBA

yjwdjfqb

huizhiaisha 发表于 2014-10-9 12:05
邮件发你了，你看一下

有两种

非常的感谢你老师！

yjwdjfqb

huizhiaisha 发表于 2014-10-9 12:05
邮件发你了，你看一下

有两种

老师你好，VBA有密码，能发下代码给我吗，谢谢你了老师！

huizhiaisha

yjwdjfqb 发表于 2014-10-9 12:16
老师你好，VBA有密码，能发下代码给我吗，谢谢你了老师！

Sub TiQu()
'①提取数据
iRx = ActiveWorkbook.ActiveSheet.Range("B60000").End(xlUp).Row
TiQu_arr = Range("b2:b" & iRx)
iRq = Sheets(2).Range("B60000").End(xlUp).Row
Date_arr = Sheets(2).Range("B2:P" & iRq)
'②處理
Call dateDoing(TiQu_arr, Date_arr)
End Sub


Public Sub dateDoing(TiQu_arr, Date_arr)
Dim ChuLi_arr()
n = 1
    For iT = 1 To UBound(TiQu_arr)
        
        For iid = 1 To UBound(Date_arr)
        
            If TiQu_arr(iT, 1) = Date_arr(iid, 3) Then
               
                ReDim Preserve ChuLi_arr(1 To 14, 1 To n)
               
                For iZJ = 1 To 14
               
                    ChuLi_arr(iZJ, n) = Date_arr(iid, iZJ + 1)
                    
                Next
               
                n = n + 1
            
                Exit For
            End If
            
        Next
        
    Next
   
    Sheets(4).Range("B2:O" & UBound(ChuLi_arr, 2)) = Application.WorksheetFunction.Transpose(ChuLi_arr)
         
End Sub