我正在嘗試執(zhí)行這種轉(zhuǎn)換。為了說明起見，我將其列為表格，因此基本上應(yīng)該重復(fù)前三列以提供多少種可用顏色。 我搜索了其他類似的種類，但是當(dāng)我想重復(fù)多列時找不到。我在網(wǎng)上找到了此代碼，但是它是Name Thank Location Thank Location Thank Location Thank Location Thank Location，并使其如下所示。Name Thank LocationSub createData()Dim dSht As WorksheetDim sSht As WorksheetDim colCount As LongDim endRow As LongDim endRow2 As LongSet dSht = Sheets("Sheet1") 'Where the data sitsSet sSht = Sheets("Sheet2") 'Where the transposed data goessSht.Range("A2:C60000").ClearContentscolCount = dSht.Range("A1").End(xlToRight).Column '// loops through all the columns extracting data where "Thank" isn't blankFor i = 2 To colCount Step 2 endRow = dSht.Cells(1, i).End(xlDown).Row For j = 2 To endRow If dSht.Cells(j, i) <> "" Then endRow2 = sSht.Range("A50000").End(xlUp).Row + 1 sSht.Range("A" & endRow2) = dSht.Range("A" & j) sSht.Range("B" & endRow2) = dSht.Cells(j, i) sSht.Range("C" & endRow2) = dSht.Cells(j, i).Offset(0, 1) End If Next jNext iEnd Sub可以幫我更改我想要的格式嗎，我嘗試將步驟2更改為1，將j從4更改為開始，但這無濟(jì)于事。例如，有2套不同的套：2套不同
2 回答
慕森卡
TA貢獻(xiàn)1806條經(jīng)驗 獲得超8個贊
這是一種通用的“取消透視”方法（所有“固定”列必須出現(xiàn)在輸入數(shù)據(jù)的左側(cè)）
測試子：
Sub Tester()
Dim p
'get the unpivoted data as a 2-D array
p = UnPivotData(Sheets("Sheet1").Range("A1").CurrentRegion, _
3, False, False)
With Sheets("Sheet1").Range("H1")
.CurrentRegion.ClearContents
.Resize(UBound(p, 1), UBound(p, 2)).Value = p 'populate array to sheet
End With
'EDIT: alternative (slower) method to populate the sheet
' from the pivoted dataset. Might need to use this
' if you have a large amount of data
Dim r As Long, c As Long
For r = 1 To Ubound(p, 1)
For c = 1 To Ubound(p, 2)
Sheets("Sheet2").Cells(r, c).Value = p(r, c)
Next c
Next r
End Sub
取消樞紐功能：
Function UnPivotData(rngSrc As Range, fixedCols As Long, _
Optional AddCategoryColumn As Boolean = True, _
Optional IncludeBlanks As Boolean = True)
Dim nR As Long, nC As Long, data, dOut()
Dim r As Long, c As Long, rOut As Long, cOut As Long, cat As Long
Dim outRows As Long, outCols As Long
data = rngSrc.Value 'get the whole table as a 2-D array
nR = UBound(data, 1) 'how many rows
nC = UBound(data, 2) 'how many cols
'calculate the size of the final unpivoted table
outRows = nR * (nC - fixedCols)
outCols = fixedCols + IIf(AddCategoryColumn, 2, 1)
'resize the output array
ReDim dOut(1 To outRows, 1 To outCols)
'populate the header row
For c = 1 To fixedCols
dOut(1, c) = data(1, c)
Next c
If AddCategoryColumn Then
dOut(1, fixedCols + 1) = "Category"
dOut(1, fixedCols + 2) = "Value"
Else
dOut(1, fixedCols + 1) = "Value"
End If
'populate the data
rOut = 1
For r = 2 To nR
For cat = fixedCols + 1 To nC
If IncludeBlanks Or Len(data(r, cat)) > 0 Then
rOut = rOut + 1
'Fixed columns...
For c = 1 To fixedCols
dOut(rOut, c) = data(r, c)
Next c
'populate unpivoted values
If AddCategoryColumn Then
dOut(rOut, fixedCols + 1) = data(1, cat)
dOut(rOut, fixedCols + 2) = data(r, cat)
Else
dOut(rOut, fixedCols + 1) = data(r, cat)
End If
End If
Next cat
Next r
UnPivotData = dOut
End Function
慕勒3428872
TA貢獻(xiàn)1848條經(jīng)驗 獲得超6個贊
這是使用數(shù)組的一種方法（最快嗎？）。這種方法比鏈接的問題更好，因為它不會在循環(huán)中讀寫范圍對象。我已經(jīng)注釋了代碼，因此您在理解它時應(yīng)該沒有問題。
Option Explicit
Sub Sample()
Dim wsThis As Worksheet, wsThat As Worksheet
Dim ThisAr As Variant, ThatAr As Variant
Dim Lrow As Long, Col As Long
Dim i As Long, k As Long
Set wsThis = Sheet1: Set wsThat = Sheet2
With wsThis
'~~> Find Last Row in Col A
Lrow = .Range("A" & .Rows.Count).End(xlUp).Row
'~~> Find total value in D,E,F so that we can define output array
Col = Application.WorksheetFunction.CountA(.Range("D2:F" & Lrow))
'~~> Store the values from the range in an array
ThisAr = .Range("A2:F" & Lrow).Value
'~~> Define your new array
ReDim ThatAr(1 To Col, 1 To 4)
'~~> Loop through the array and store values in new array
For i = LBound(ThisAr) To UBound(ThisAr)
k = k + 1
ThatAr(k, 1) = ThisAr(i, 1)
ThatAr(k, 2) = ThisAr(i, 2)
ThatAr(k, 3) = ThisAr(i, 3)
'~~> Check for Color 1
If ThisAr(i, 4) <> "" Then ThatAr(k, 4) = ThisAr(i, 4)
'~~> Check for Color 2
If ThisAr(i, 5) <> "" Then
k = k + 1
ThatAr(k, 1) = ThisAr(i, 1)
ThatAr(k, 2) = ThisAr(i, 2)
ThatAr(k, 3) = ThisAr(i, 3)
ThatAr(k, 4) = ThisAr(i, 5)
End If
'~~> Check for Color 3
If ThisAr(i, 6) <> "" Then
k = k + 1
ThatAr(k, 1) = ThisAr(i, 1)
ThatAr(k, 2) = ThisAr(i, 2)
ThatAr(k, 3) = ThisAr(i, 3)
ThatAr(k, 4) = ThisAr(i, 6)
End If
Next i
End With
'~~> Create headers in Sheet2
Sheet2.Range("A1:D1").Value = Sheet1.Range("A1:D1").Value
'~~> Output the array
wsThat.Range("A2").Resize(Col, 4).Value = ThatAr
End Sub
- 2 回答
- 0 關(guān)注
- 701 瀏覽
添加回答
舉報
0/150
提交
取消