|
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件 ★ 免费下载 ★ ★ 使用帮助★
- Sub danjiazhuanhuan()
- Dim objDicUnitPrice As Object, objDicQuantity As Object
- Dim shReplace As Worksheet, shSource As Worksheet
- Dim lngRows As Long, arrTemp As Variant
- Dim arrResult As Variant, lngIndex As Long
- Dim lngRow As Long, lngCol As Long
- Dim strKey As String, dblItem As Double
- Dim dblCurUnitPrice As Double, dblCurQuantity As Double
-
-
- Set shReplace = Sheets("替换内容")
- Set shSource = Sheets("销售明细")
- Set objDicUnitPrice = CreateObject("Scripting.Dictionary")
- Set objDicQuantity = CreateObject("Scripting.Dictionary")
-
- lngRows = shReplace.Range("A" & Rows.Count).End(xlUp).Row
- arrTemp = shReplace.Range("A2:D" & lngRows)
- For lngRow = LBound(arrTemp) To UBound(arrTemp)
- strKey = Format(arrTemp(lngRow, 1), "yyyymmdd") & arrTemp(lngRow, 2)
- dblItem = arrTemp(lngRow, 4): objDicUnitPrice(strKey) = dblItem
- dblItem = arrTemp(lngRow, 3): objDicQuantity(strKey) = dblItem
- Next
-
- lngRows = shSource.Range("A" & Rows.Count).End(xlUp).Row
- arrTemp = shSource.Range("A2:F" & lngRows)
- ReDim arrResult(LBound(arrTemp, 2) To UBound(arrTemp, 2), 1 To 1)
-
- For lngRow = LBound(arrTemp) To UBound(arrTemp)
- strKey = Format(arrTemp(lngRow, 1), "yyyymmdd") & arrTemp(lngRow, 3)
- If objDicUnitPrice.Exists(strKey) Then
- dblCurUnitPrice = arrTemp(lngRow, 5)
- dblCurQuantity = arrTemp(lngRow, 4)
- If dblCurQuantity >= objDicQuantity(strKey) Then
- lngIndex = lngIndex + 1
- ReDim Preserve arrResult(LBound(arrTemp, 2) To UBound(arrTemp, 2), 1 To lngIndex)
- For lngCol = LBound(arrTemp, 2) To UBound(arrTemp, 2)
- arrResult(lngCol, lngIndex) = arrTemp(lngRow, lngCol)
- Next
- arrResult(4, lngIndex) = dblCurQuantity - objDicQuantity(strKey)
- arrResult(6, lngIndex) = arrResult(4, lngIndex) * arrResult(5, lngIndex)
-
- lngIndex = lngIndex + 1
- ReDim Preserve arrResult(LBound(arrTemp, 2) To UBound(arrTemp, 2), 1 To lngIndex)
- For lngCol = LBound(arrTemp, 2) To UBound(arrTemp, 2)
- arrResult(lngCol, lngIndex) = arrTemp(lngRow, lngCol)
- Next
- arrResult(2, lngIndex) = "新客户"
- arrResult(4, lngIndex) = objDicQuantity(strKey)
- arrResult(5, lngIndex) = objDicUnitPrice(strKey)
- arrResult(6, lngIndex) = arrResult(4, lngIndex) * arrResult(5, lngIndex)
- objDicQuantity.Remove (strKey): objDicUnitPrice.Remove (strKey)
- Else
- lngIndex = lngIndex + 1
- ReDim Preserve arrResult(LBound(arrTemp, 2) To UBound(arrTemp, 2), 1 To lngIndex)
- For lngCol = LBound(arrTemp, 2) To UBound(arrTemp, 2)
- arrResult(lngCol, lngIndex) = arrTemp(lngRow, lngCol)
- Next
- arrResult(4, lngIndex) = 0
- arrResult(6, lngIndex) = 0
-
- lngIndex = lngIndex + 1
- ReDim Preserve arrResult(LBound(arrTemp, 2) To UBound(arrTemp, 2), 1 To lngIndex)
- For lngCol = LBound(arrTemp, 2) To UBound(arrTemp, 2)
- arrResult(lngCol, lngIndex) = arrTemp(lngRow, lngCol)
- Next
- arrResult(2, lngIndex) = "新客户"
- arrResult(4, lngIndex) = dblCurQuantity
- arrResult(5, lngIndex) = objDicUnitPrice(strKey)
- arrResult(6, lngIndex) = arrResult(4, lngIndex) * arrResult(5, lngIndex)
- objDicQuantity(strKey) = objDicQuantity(strKey) - dblCurQuantity
- End If
- Else
- lngIndex = lngIndex + 1
- ReDim Preserve arrResult(LBound(arrTemp, 2) To UBound(arrTemp, 2), 1 To lngIndex)
- For lngCol = LBound(arrTemp, 2) To UBound(arrTemp, 2)
- arrResult(lngCol, lngIndex) = arrTemp(lngRow, lngCol)
- Next
- End If
- Next
-
- arrResult = Application.WorksheetFunction.Transpose(arrResult)
-
- shSource.Range("A2").Resize(UBound(arrResult), UBound(arrResult, 2)) = arrResult
-
- End Sub
复制代码 |
|