Excel矩阵的行列转置问题

yuzhj231

？？难道无解？

lsdongjh

有办法，不过不一定符合实际情况，按先出先进原则，如：

大库        北国        先天下        益友
-7        -3        2        8

运算结果为：
大库    先天下    2
大库    益友    5
北国    益友    3

也许实际情况是
大库   益友    7
北国    先天下    2
北国    益友   1

yuzhj231

lsdongjh 发表于 2018-7-4 14:58
有办法，不过不一定符合实际情况，按先出先进原则，如：

大库        北国        先天下        益友

嗯，已经非常符合实际了，求实现代码

一把小刀闯天下

yuzhj231 发表于 2018-7-4 15:41
嗯，已经非常符合实际了，求实现代码

'细看确实有点晕

'05566-V773L调出数量都为5?  简单的均分? 我按10来处理，因为没有规则

Option Explicit

Sub tes()
  Dim i, j, k, a, b, arr, n
  arr = [a1].CurrentRegion
  ReDim brr(1 To Rows.Count, 1 To 4)
  For i = 2 To UBound(arr, 1)
    a = 0: b = 0
    For j = 2 To UBound(arr, 2)
      If arr(i, j) < 0 Then a = a + 1
      If arr(i, j) > 0 Then b = b + 1
    Next
    If a > b Then
      Do
        For j = 2 To UBound(arr, 2)
          If arr(i, j) < 0 Then
            n = n + 1
            For k = 2 To UBound(arr, 2)
              If arr(i, k) > 0 Then Exit For
            Next
            brr(n, 1) = arr(i, 1): brr(n, 2) = arr(1, j)
            brr(n, 3) = arr(1, k): brr(n, 4) = arr(i, k)
            arr(i, j) = 0
          End If
        Next
        a = a - 1
      Loop Until a = 0
    End If
    If a < b Then
      Do
        For j = 2 To UBound(arr, 2)
          If arr(i, j) < 0 Then
            n = n + 1
            For k = 2 To UBound(arr, 2)
              If arr(i, k) > 0 Then Exit For
            Next
            brr(n, 1) = arr(i, 1): brr(n, 2) = arr(1, j)
            brr(n, 3) = arr(1, k): brr(n, 4) = arr(i, k)
            arr(i, k) = 0
          End If
        Next
        b = b - 1
      Loop Until b = 0
    End If
  Next
  [j2].Resize(n, UBound(brr, 2)) = brr
End Sub

一把小刀闯天下

我给你加个规则，觉得更靠谱些

把If a > b Then...end if 内的（a<b中也有一行，不要改错了）
brr(n, 3) = arr(1, k): brr(n, 4) = arr(i, k) 改成：

brr(n, 3) = arr(1, k): brr(n, 4) = Abs(arr(i, j))

lsdongjh

1. Sub Test()
   
2.     Dim arrSource As Variant, arrTemp As Variant, arrResult As Variant
   
3.     Dim lngRows As Long, lngCols As Long
   
4.     Dim lngR As Long, lngC As Long
   
5.     Dim lngRow As Long, lngCol As Long
   
6.     Dim intIN As Integer, intOut As Integer
   
7.     Dim lngIndex As Long
   
8.    
   
9.     arrSource = Sheet1.Range("A1").CurrentRegion
   
10.     lngRows = UBound(arrSource)
    
11.     lngCols = UBound(arrSource, 2)
    
12. 
    
13.     lngIndex = 1
    
14.     ReDim arrResult(1 To 4, 1 To lngIndex)
    
15.     arrResult(1, 1) = "商品编号"
    
16.     arrResult(2, 1) = "调出门店"
    
17.     arrResult(3, 1) = "调入门店"
    
18.     arrResult(4, 1) = "调入数量"
    
19. 
    
20.    
    
21.     For lngRow = 2 To lngRows
    
22.         ReDim arrTemp(1 To lngCols - 2, 1 To 5)
    
23.         intIN = 1
    
24.         intOut = 1
    
25.         For lngCol = 2 To lngCols
    
26.             If arrSource(lngRow, lngCol) < 0 Then
    
27.                 arrTemp(intOut, 1) = arrSource(lngRow, 1)
    
28.                 arrTemp(intOut, 2) = arrSource(1, lngCol)
    
29.                 arrTemp(intOut, 3) = arrSource(lngRow, lngCol)
    
30.                 intOut = intOut + 1
    
31.             ElseIf arrSource(lngRow, lngCol) > 0 Then
    
32.                 arrTemp(intIN, 1) = arrSource(lngRow, 1)
    
33.                 arrTemp(intIN, 4) = arrSource(1, lngCol)
    
34.                 arrTemp(intIN, 5) = arrSource(lngRow, lngCol)
    
35.                 intIN = intIN + 1
    
36.             End If
    
37.         Next
    
38.         
    
39.         
    
40.         For lngR = 1 To intOut - 1
    
41.             For lngC = 1 To intIN - 1
    
42.                 If arrTemp(lngC, 5) > 0 Then
    
43.                     lngIndex = lngIndex + 1
    
44.                     ReDim Preserve arrResult(1 To 4, 1 To lngIndex)
    
45.                     arrResult(1, lngIndex) = arrTemp(lngR, 1)
    
46.                     arrResult(2, lngIndex) = arrTemp(lngR, 2)
    
47.                     arrResult(3, lngIndex) = arrTemp(lngC, 4)
    
48.                     If (arrTemp(lngR, 3) + arrTemp(lngC, 5)) >= 0 Then
    
49.                         arrResult(4, lngIndex) = arrTemp(lngR, 3) * -1
    
50.                         arrTemp(lngR, 3) = 0
    
51.                         arrTemp(lngC, 5) = arrTemp(lngR, 3) + arrTemp(lngC, 5)
    
52.                     Else
    
53.                         arrResult(4, lngIndex) = arrTemp(lngC, 5)
    
54.                         arrTemp(lngR, 3) = arrTemp(lngR, 3) + arrTemp(lngC, 5)
    
55.                         arrTemp(lngC, 5) = 0
    
56.                     End If
    
57.                 End If
    
58.             Next
    
59.         Next
    
60.     Next
    
61.    
    
62.     arrResult = Application.WorksheetFunction.Transpose(arrResult)
    
63.     Sheet2.UsedRange.ClearContents
    
64.     Sheet2.Range("K1").Resize(lngIndex, 4) = arrResult
    
65. End Sub
    

复制代码

lsdongjh

代码审核中，见附件： 调拨.rar (19.04 KB, 下载次数: 17)

2018-7-4 16:08 上传

点击文件名下载附件

一把小刀闯天下

'加了个相等

Option Explicit

Sub tes()
  Dim i, j, k, a, b, arr, n, t1, t2
  arr = [a1].CurrentRegion
  ReDim brr(1 To Rows.Count, 1 To 4)
  For i = 2 To UBound(arr, 1)
    a = 0: b = 0
    For j = 2 To UBound(arr, 2)
      If arr(i, j) < 0 Then a = a + 1
      If arr(i, j) > 0 Then b = b + 1
    Next
    t1 = a: t2 = b
    Do
      For j = 2 To UBound(arr, 2)
        If arr(i, j) < 0 Then
          n = n + 1
          For k = 2 To UBound(arr, 2)
            If t1 = t2 Then
              If arr(i, k) > 0 And arr(i, k) = Abs(arr(i, j)) Then Exit For
            Else
              If arr(i, k) > 0 Then Exit For
            End If
          Next
          If k = UBound(arr, 2) + 1 Then MsgBox "检查数据！": Exit For
          brr(n, 1) = arr(i, 1): brr(n, 2) = arr(1, j)
          brr(n, 3) = arr(1, k)
          If t1 > t2 Then
            brr(n, 4) = Abs(arr(i, j))
            arr(i, j) = 0
          ElseIf t1 < t2 Then
            brr(n, 4) = arr(i, k)
            arr(i, k) = 0
          Else
            brr(n, 4) = arr(i, k)
            arr(i, j) = 0: arr(i, k) = 0
          End If
        End If
      Next
      If t1 > t2 Then a = a - 1 Else b = b - 1
    Loop Until a = 0 Or b = 0
  Next
  [j2].Resize(n, UBound(brr, 2)) = brr
End Sub

yuzhj231

lsdongjh 发表于 2018-7-4 16:09
代码审核中，见附件：

您好，能教我增加行和列需要修改哪里么？

yuzhj231

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

已经深刻领悟到此代码内涵，有个问题，是否加一个等值判断，调出和调入相同的不进行拆分、