- Option Explicit
- Sub Demo()
- Dim objDic As Object, rngData As Range
- Dim i As Long, iR As Long, sKey As String, sDate As String, aRes()
- Dim arrData
- Dim oSht1 As Worksheet: Set oSht1 = Sheets("数据处理")
- Dim oSht2 As Worksheet: Set oSht2 = Sheets("每日汇总")
- Set rngData = oSht1.Range("A1").CurrentRegion
- arrData = rngData.Value
- iR = 1
- ReDim aRes(1 To UBound(arrData), 1 To 6)
- sDate = arrData(2, 1): aRes(iR, 1) = "'" & sDate
- For i = LBound(arrData) + 1 To UBound(arrData)
- sKey = arrData(i, 1)
- If sKey <> sDate Then
- sDate = sKey
- iR = iR + 1
- aRes(iR, 1) = "'" & sDate
- End If
- Select Case arrData(i, 8)
- Case "转移入库", "转移出库"
- aRes(iR, 2) = aRes(iR, 2) + arrData(i, 5)
- If InStr(1, aRes(iR, 3), arrData(i, 2)) = 0 Then
- If Len(aRes(iR, 3)) = 0 Then
- aRes(iR, 3) = arrData(i, 2)
- Else
- aRes(iR, 3) = aRes(iR, 3) & Chr(10) & arrData(i, 2)
- End If
- End If
- If InStr(1, aRes(iR, 4), arrData(i, 6)) = 0 Then
- If Len(aRes(iR, 4)) = 0 Then
- aRes(iR, 4) = arrData(i, 6)
- Else
- aRes(iR, 4) = aRes(iR, 4) & Chr(10) & arrData(i, 6)
- End If
- End If
- Case "门诊发药", "病人退回", "库存调整"
- aRes(iR, 5) = aRes(iR, 5) - arrData(i, 5)
- End Select
- aRes(iR, 6) = arrData(i, 4)
- Next i
- With oSht2
- Dim lstR As Long: lstR = .Cells(.Rows.Count, 1).End(xlUp).Row
- .Range("2:" & lstR).ClearContents
- .Range("A2").Resize(iR, UBound(aRes, 2)) = aRes
- End With
- End Sub
复制代码 |