找出字母对应的第一个非空数值

lijian318

找出字母对应的第一个非空数值 工作簿22.zip (6.26 KB, 下载次数: 12)

2019-3-15 11:09 上传

点击文件名下载附件

苏小亓

1. =OFFSET($B$1,MIN(IF(($B$1:$B$12>0)*($A$1:$A$12=D2),ROW($B$1:$B$12)))-1,)

复制代码

数组

苏小亓

工作簿22.zip (6.5 KB, 下载次数: 3)

2019-3-15 11:21 上传

点击文件名下载附件

lsdongjh

1. Sub Test()
   
2.     Dim lngRows As Long, arr As Variant
   
3.     Dim objDic As Object
   
4.     Dim strKey As String, strItem As String
   
5.    
   
6.     lngRows = Sheet1.Range("A" & Rows.Count).End(xlUp).Row
   
7.     arr = Sheet1.Range("A1:B" & lngRows)
   
8.     Set objDic = CreateObject("Scripting.Dictionary")
   
9.    
   
10.     For lngRows = LBound(arr) To UBound(arr)
    
11.         strKey = Trim(CStr(arr(lngRows, 1)))
    
12.         strItem = Trim(CStr(arr(lngRows, 2)))
    
13.         If strItem <> "" And objDic.Exists(strKey) = False Then
    
14.             objDic(strKey) = Val(strItem)
    
15.         End If
    
16.     Next
    
17.    
    
18.     lngRows = objDic.Count
    
19.     Sheet1.Range("D2:E" & Rows.Count).Clear
    
20.    
    
21.     Sheet1.Range("D2").Resize(lngRows, 1) = Application.WorksheetFunction.Transpose(objDic.keys)
    
22.     Sheet1.Range("E2").Resize(lngRows, 1) = Application.WorksheetFunction.Transpose(objDic.items)
    
23. End Sub

复制代码

lijian318

苏小亓 发表于 2019-3-15 11:21
数组

数组会做，需要用vba

lijian318

lsdongjh 发表于 2019-3-15 11:22

我想要的是在D列字母已存在的情况下，用最简短的代码找出对应的第一个非空数值

一把小刀闯天下

Option Explicit

Sub test()
  Dim arr, i, m, flag As Boolean
  arr = Range("a2:b" & Cells(Rows.Count, "a").End(xlUp).Row + 1)
  For i = 1 To UBound(arr, 1) - 1
    If Not flag And Len(arr(i, 2)) > 0 Then
      m = m + 1: flag = True
      arr(m, 1) = arr(i, 1): arr(m, 2) = arr(i, 2)
    End If
    If arr(i + 1, 1) <> arr(i, 1) Then flag = False
  Next
  With [d2]
    .Resize(Rows.Count - 1, 2).ClearContents
    If m > 0 Then .Resize(m, 2) = arr
  End With
End Sub

lsdongjh

lijian318 发表于 2019-3-15 11:31
我想要的是在D列字母已存在的情况下，用最简短的代码找出对应的第一个非空数值

用了字典，非常简单，改一下后半部分：

1. Sub Test()
   
2.     Dim lngRows As Long, arr As Variant
   
3.     Dim objDic As Object
   
4.     Dim strKey As String, strItem As String
   
5.    
   
6.     lngRows = Sheet1.Range("A" & Rows.Count).End(xlUp).Row
   
7.     arr = Sheet1.Range("A1:B" & lngRows)
   
8.     Set objDic = CreateObject("Scripting.Dictionary")
   
9.    
   
10.     For lngRows = LBound(arr) To UBound(arr)
    
11.         strKey = Trim(CStr(arr(lngRows, 1)))
    
12.         strItem = Trim(CStr(arr(lngRows, 2)))
    
13.         If strItem <> "" And objDic.Exists(strKey) = False Then
    
14.             objDic(strKey) = Val(strItem)
    
15.         End If
    
16.     Next
    
17.    
    
18.     lngRows = Sheet1.Range("D" & Rows.Count).End(xlUp).Row
    
19.     arr = Sheet1.Range("D2:E" & lngRows)
    
20.     For lngRows = LBound(arr) To UBound(arr)
    
21.         strKey = Trim(CStr(arr(lngRows, 1)))
    
22.         arr(lngRows, 2) = objDic(strKey)
    
23.     Next
    
24.    
    
25.     Sheet1.Range("D2").Resize(UBound(arr), 2) = arr
    
26. End Sub

复制代码

lijian318

我还以为可以用一两句代码就能得出结果呢，果然我想得太简单了！

一把小刀闯天下

Option Explicit

Sub test()
  Dim arr, i, dic
  Set dic = CreateObject("scripting.dictionary")
  arr = [a1].CurrentRegion
  For i = 1 To UBound(arr, 1)
    If Not dic.exists(arr(i, 1)) And Len(arr(i, 2)) > 0 Then dic(arr(i, 1)) = arr(i, 2)
  Next
  arr = Range("d2:e" & Cells(Rows.Count, "d").End(xlUp).Row)
  For i = 1 To UBound(arr, 1)
    arr(i, 2) = IIf(dic.exists(arr(i, 1)), dic(arr(i, 1)), vbNullString)
  Next
  [d2].Resize(UBound(arr, 1), 2) = arr
End Sub