Excel矩阵的行列转置问题

lsdongjh

yuzhj231 发表于 2018-7-12 10:18
已经深刻领悟到此代码内涵，有个问题，是否加一个等值判断，调出和调入相同的不进行拆分、

不明白你说的，能不能举个例子？

yuzhj231

lsdongjh 发表于 2018-7-12 10:27
不明白你说的，能不能举个例子？

您好，看一下如下两个图，第一行：调入万达1件，保定调出1件，最后结果是保定调给万达1；唐爱调入5件，北国调出5件，最后结果是北国调给唐爱5；目前的宏实现效果没有达到这样的结果，在实际业务中会增加业务成本。

用宏前

      

用宏后

lsdongjh

重新看一下10楼和12楼再说话，勿忘初心

yuzhj231

lsdongjh 发表于 2018-7-12 21:41
重新看一下10楼和12楼再说话，勿忘初心

您写的这个没有问题，我想了一下，可以分两步实现我说的那种，第一步：先将一行中相同进出的店遍历出来写在数组1中，原数组中对应单元格设为空，第二步就是遍历原数组就是您写的代码。

zhangcheng6688

lsdongjh 发表于 2018-7-4 16:06

小弟看不懂呀

yuzhj231

Sub Test()
    Dim arrSource As Variant, arrTemp As Variant, arrResult As Variant, arrSource1  As Variant
    Dim lngRows As Long, lngCols As Long
    Dim lngR As Long, lngC As Long
    Dim lngRow As Long, lngCol As Long
    Dim intIN As Integer, intOut As Integer
    Dim lngIndex As Long
   
    arrSource = Sheet1.Range("A1").CurrentRegion
        arrSource1 = Sheet1.Range("A1").CurrentRegion
    lngRows = UBound(arrSource)
    lngCols = UBound(arrSource, 2)

    lngIndex = 1
    ReDim arrResult(1 To 4, 1 To lngIndex)
    arrResult(1, 1) = "商品编号"
    arrResult(2, 1) = "调出门店"
    arrResult(3, 1) = "调入门店"
    arrResult(4, 1) = "调入数量"



   
'
'For nub2 = 2 To lngRows
'    For nub1 = 2 To lngCols
'      nub = arrSource(nub2, nub1) + nub
'     Next
'     If nub <> 0 Then
'     MsgBox arrSource(nub2, 1) & "调拨失衡"
'     GoTo xx
'
'     End If
'Next

   
    For lngRow = 2 To lngRows
        ReDim arrTemp(1 To lngCols - 2, 1 To 5)
        intIN = 1
        intOut = 1
        For lngCol = 2 To lngCols
            If arrSource(lngRow, lngCol) < 0 Then
                arrTemp(intOut, 1) = arrSource(lngRow, 1)
                arrTemp(intOut, 2) = arrSource(1, lngCol)
                arrTemp(intOut, 3) = arrSource(lngRow, lngCol)
                arrSource(lngRow, lngCol) = 0
                intOut = intOut + 1
               
               
          For i = 2 To lngCols
         
           If arrSource(lngRow, i) > 0 And arrSource(lngRow, i) = arrTemp(intOut - 1, 3) * -1 Then
                arrTemp(intIN, 1) = arrSource(lngRow, 1)
                arrTemp(intIN, 4) = arrSource(1, i)
                arrTemp(intIN, 5) = arrSource(lngRow, i)
                arrSource(lngRow, i) = 0
                intIN = intIN + 1
                GoTo xxq
             End If
               
            Next
xxq:

          ElseIf arrSource(lngRow, lngCol) > 0 Then
                arrTemp(intIN, 1) = arrSource(lngRow, 1)
                arrTemp(intIN, 4) = arrSource(1, lngCol)
                arrTemp(intIN, 5) = arrSource(lngRow, lngCol)
                arrSource(lngRow, lngCol) = 0
                intIN = intIN + 1
             For j = 2 To lngCols
                If arrSource(lngRow, j) < 0 And arrSource(lngRow, j) = arrTemp(intIN - 1, 5) * -1 Then
                arrTemp(intOut, 1) = arrSource(lngRow, 1)
                arrTemp(intOut, 2) = arrSource(1, j)
                arrTemp(intOut, 3) = arrSource(lngRow, j)
                arrSource(lngRow, j) = 0
                intOut = intOut + 1
                GoTo xxx
             End If
               
                Next
xxx:
               
               
            End If
        Next
        
        
        For lngR = 1 To intOut - 1
            For lngC = 1 To intIN - 1
                If arrTemp(lngC, 5) > 0 Then
                    lngIndex = lngIndex + 1
                    ReDim Preserve arrResult(1 To 4, 1 To lngIndex)
                    arrResult(1, lngIndex) = arrTemp(lngR, 1)
                    arrResult(2, lngIndex) = arrTemp(lngR, 2)
                    arrResult(3, lngIndex) = arrTemp(lngC, 4)
                    If (arrTemp(lngR, 3) + arrTemp(lngC, 5)) = 0 Then
                        arrResult(4, lngIndex) = arrTemp(lngR, 3) * -1
                        arrTemp(lngR, 3) = 0
                        arrTemp(lngC, 5) = 0
                      ElseIf (arrTemp(lngR, 3) + arrTemp(lngC, 5)) > 0 Then
                    
                         arrResult(4, lngIndex) = arrTemp(lngR, 3) * -1
                        arrTemp(lngR, 3) = 0
                        
                        arrTemp(lngC, 5) = arrTemp(lngR, 3) + arrTemp(lngC, 5)
                    ElseIf (arrTemp(lngR, 3) + arrTemp(lngC, 5)) < 0 Then
                    
                        arrResult(4, lngIndex) = arrTemp(lngC, 5)
                        arrTemp(lngR, 3) = arrTemp(lngR, 3) + arrTemp(lngC, 5)
                        arrTemp(lngC, 5) = 0
                    End If
                End If
            Next
        Next
    Next
   
    arrResult = Application.WorksheetFunction.Transpose(arrResult)
    Sheet2.UsedRange.ClearContents
    Sheet2.Range("K1").Resize(lngIndex, 4) = arrResult
End Sub

yuzhj231

lsdongjh 发表于 2018-7-12 21:41
重新看一下10楼和12楼再说话，勿忘初心

在您的框架内实现了我说的那种，代码请看26楼