在數組中轉換和重新排列範圍操作

Question

我有以下代碼。我將逐步解釋這一點。

6001 1001 3001 
3001 1002 2001 
2001 1003 3002 
3002 1004 2002 
2002 1005 3003 
3003 1006 2003 

該數據被佈置在單行中，以便於去除重複序列來如下的：

6001 1001 3001 1002 2001 1003 3002 1004 2002 1005 3003 1006 2003 1007 3004 1008 6002 2001 1009 

此外，這種設置在以下格式：

6001 2003 1012 3006 
1001 1007 2005 1018 
3001 3004 1013 2002 
1002 1008 3010 2005 
2001 6002 1014 1019 
1003 2001 2006 3008 
3002 1009 1015 1020 
1004 3005 3009 2006 
2002 1010 1016  
1005 2004 2003  
3003 1011 2004  
1006 3007 1017  

請幫助我將此代碼轉換爲使用數組而不是將數據保存到不同工作表中的單元格。

Sub ARRANGE() 

Dim InputRng As Range, OutRng As Range 
Dim row As Integer 
Dim rng As Range, j As Long 
Dim lastRow As Long 


Set InputRng = Sheet1.Range("A1:C20") 'A1 to C20 range is selected for operation 

Set OutRng = Sheet2.Cells(1, 1) 'Cell A2 on another sheet 

'---as indicated below data is converted to single row 

Application.ScreenUpdating = False 
xRows = InputRng.Rows.Count 
xcols = InputRng.Columns.Count 
For i = 1 To xRows 
    InputRng.Rows(i).Copy OutRng 
    Set OutRng = OutRng.Offset(0, xcols + 0) 

Next 
Application.ScreenUpdating = True 

' duplicates comming one after other are deleted by below code 

row = 0 ' Initialize variable. 
For i = 1 To 3 * 20 
If Sheet2.Cells(1, i).Value = Sheet2.Cells(1, i + 1).Value Then 
Sheet2.Cells(1, i).Delete 
End If 
Next i 


' data is rearranged to creat 12 number of rows and dynamic number of colums 
j = 1 

     For i = 1 To Sheet2.Cells(1, Columns.Count).End(xlToLeft).Column Step 12 
      Set rng = Sheet2.Range(Sheet_Pipe_Config.Cells(1, i), Sheet2.Cells(1, i + 12)) 
      Sheet3.Cells(1, j).Resize(rng.Count - 1, 1) = Application.Transpose(rng) 

      j = j + 1 
     Next i 


End Sub 

Answer 1

下面是幾個可能有幫助的代碼。

注意：在Set OutRng = Sheet2.Cells(1, 1) 'Cell A2 on another sheet,Cells(1,1)是單元格A1而不是A2。

考慮：

Dim ValuesFormat1 as Variant 

ValuesFormatIn = Sheet1.Range("A1:C20").Value 

的有關聲明變ValuesFormatIn轉換，從範圍到它二維數組並加載所有的值。通常在二維數組中，第一維是列，第二維是行。對於從工作表讀取或將要寫入工作表的數組，尺寸是相反的。這是因爲雖然ValuesFormatIn是大小，以便：

ReDim ValuesFormatIn(1 To 20, 1 To 3) 

在你的原代碼，你通過一次運動細胞一排3 * 20範圍內轉換爲1 * 60範圍內。您可以使用ReDim語句來增加或減少最後一個維度的出現次數，但是沒有將2D，3 * 20元素數組轉換爲1D，60個元素數組的標準函數。如果您搜索「VBA數組」，您會發現將執行此類轉換的VBA例程。但是，我不相信這是最簡單的方法。

考慮：

Dim NumColsOut As Long 
Const NumRowsOut As Long = 12 
Dim ValuesFormatOut As Variant 

NumColsOut = (UBound(ValuesFormatIn, 1) * UBound(ValuesFormatIn, 2) _ 
                + NumRowsOut - 1) \ NumRowsOut 
ReDim ValuesFormatOut(1 To NumRowsOut, 1 To NumColsOut) 

這個尺寸ValuesFormatOut因此它可以接受整組輸入值，即使不是一個單一的重複值的輸入值中找到。我們可以將這個數組寫入一個工作表數組中，並且未使用尾部條目，所以我相信這將是最簡單的方法。

然後，此代碼會將數組ValuesFormatIn中的值移動到數組ValuesFormatout中，以使與其前任匹配的任何值不變。

Dim RowInCrnt As Long 
    Dim ColInCrnt As Long 
    Dim RowOutCrnt As Long 
    Dim ColOutCrnt As Long 
    Dim ValueCrnt As Long 
    Dim ValueLast As Long 

    ValueLast = -1  ' For the code below to work, -1 muat be an inpossible value 
    RowOutCrnt = 1 
    ColOutCrnt = 1 

    For RowInCrnt = 1 To UBound(ValuesFormatIn, 1) 
    For ColInCrnt = 1 To UBound(ValuesFormatIn, 2) 
     If ValuesFormatIn(RowInCrnt, ColInCrnt) <> "" And _ 
     IsNumeric(ValuesFormatIn(RowInCrnt, ColInCrnt)) Then 
     ValueCrnt = ValuesFormatIn(RowInCrnt, ColInCrnt) 
     If ValueLast <> ValueCrnt Then 
      ValuesFormatOut(RowOutCrnt, ColOutCrnt) = ValueCrnt 
      ValueLast = ValueCrnt 
      RowOutCrnt = RowOutCrnt + 1 
      If RowOutCrnt > NumRowsOut Then 
      ColOutCrnt = ColOutCrnt + 1 
      RowOutCrnt = 1 
      End If 
     End If 
     Else 
     ' Probably a blank cell 
     ValueLast = -1 
     End If 
    Next 
    Next 

最後，這段代碼將輸出ValuesFormatOut

' Output ValuesFormatOut 
With Sheet2 
    .Range(.Cells(1, 1), .Cells(NumRowsOut, NumColsOut)).Value = ValuesFormatOut 
End With