각 열 셀에 대한 열 셀 확장
3개의 서로 다른 데이터 집합이 있습니다(다른 열에 있음).
- 열 A에 있는 동물(5가지 종류)
- B열 과일(1000가지 종류)
- 열 C에 있는 국가(10가지 종류)
이 3개의 데이터 수집을 통해 총 50k에 해당하는 col의 요소에 대해 5x1000x10을 받고 싶습니다.EFG(각 과일과 각 국가에 해당하는 각 동물).
값을 수동으로 복사하여 붙여넣는 방식으로 수행할 수 있지만 시간이 오래 걸립니다.VBA 코드로 자동화할 수 있는 방법이 있습니까?
위에 제시된 것처럼 무제한 데이터 세트에 대한 보편적인 공식이 있습니까?명확하지 않은 사항이 있으면 알려주시기 바랍니다.
다음은 데이터의 작은 예와 결과가 어떻게 나타나는지 보여줍니다.
저는 보편적으로 이것이 임의의 수의 열과 각각의 항목을 수용하기를 원한다고 생각합니다.몇 가지 변형 배열은 각 값에 대한 반복 주기를 계산하는 데 필요한 치수를 제공해야 합니다.
Option Explicit
Sub main()
Call for_each_in_others(rDATA:=Worksheets("Sheet3").Range("A3"), bHDR:=True)
End Sub
Sub for_each_in_others(rDATA As Range, Optional bHDR As Boolean = False)
Dim v As Long, w As Long
Dim iINCROWS As Long, iMAXROWS As Long, sErrorRng As String
Dim vVALs As Variant, vTMPs As Variant, vCOLs As Variant
On Error GoTo bm_Safe_Exit
appTGGL bTGGL:=False
With rDATA.Parent
With rDATA(1).CurrentRegion
'Debug.Print rDATA(1).Row - .Cells(1).Row
With .Resize(.Rows.Count - (rDATA(1).Row - .Cells(1).Row), .Columns.Count).Offset(2, 0)
sErrorRng = .Address(0, 0)
vTMPs = .Value2
ReDim vCOLs(LBound(vTMPs, 2) To UBound(vTMPs, 2))
iMAXROWS = 1
'On Error GoTo bm_Output_Exceeded
For w = LBound(vTMPs, 2) To UBound(vTMPs, 2)
vCOLs(w) = Application.CountA(.Columns(w))
iMAXROWS = iMAXROWS * vCOLs(w)
Next w
'control excessive or no rows of output
If iMAXROWS > Rows.Count Then
GoTo bm_Output_Exceeded
ElseIf .Columns.Count = 1 Or iMAXROWS = 0 Then
GoTo bm_Nothing_To_Do
End If
On Error GoTo bm_Safe_Exit
ReDim vVALs(LBound(vTMPs, 1) To iMAXROWS, LBound(vTMPs, 2) To UBound(vTMPs, 2))
iINCROWS = 1
For w = LBound(vVALs, 2) To UBound(vVALs, 2)
iINCROWS = iINCROWS * vCOLs(w)
For v = LBound(vVALs, 1) To UBound(vVALs, 1)
vVALs(v, w) = vTMPs((Int(iINCROWS * ((v - 1) / UBound(vVALs, 1))) Mod vCOLs(w)) + 1, w)
Next v
Next w
End With
End With
.Cells(2, UBound(vVALs, 2) + 2).Resize(1, UBound(vVALs, 2) + 2).EntireColumn.Delete
If bHDR Then
rDATA.Cells(1, 1).Offset(-1, 0).Resize(1, UBound(vVALs, 2)).Copy _
Destination:=rDATA.Cells(1, UBound(vVALs, 2) + 2).Offset(-1, 0)
End If
rDATA.Cells(1, UBound(vVALs, 2) + 2).Resize(UBound(vVALs, 1), UBound(vVALs, 2)) = vVALs
End With
GoTo bm_Safe_Exit
bm_Nothing_To_Do:
MsgBox "There is not enough data in " & sErrorRng & " to perform expansion." & Chr(10) & _
"This could be due to a single column of values or one or more blank column(s) of values." & _
Chr(10) & Chr(10) & "There is nothing to expand.", vbInformation, _
"Single or No Column of Raw Data"
GoTo bm_Safe_Exit
bm_Output_Exceeded:
MsgBox "The number of expanded values created from " & sErrorRng & _
" (" & Format(iMAXROWS, "\> #, ##0") & " rows × " & UBound(vTMPs, 2) & _
" columns) exceeds the rows available (" & Format(Rows.Count, "#, ##0") & ") on this worksheet.", vbCritical, _
"Too Many Entries"
bm_Safe_Exit:
appTGGL
End Sub
Sub appTGGL(Optional bTGGL As Boolean = True)
Application.EnableEvents = bTGGL
Application.ScreenUpdating = bTGGL
End Sub
열 머리글 레이블을 열 A에서 시작하는 행 2에 넣고 데이터를 바로 아래에 놓습니다.
워크시트의 행 수를 초과할 경우 경고하는 오류 컨트롤을 추가했습니다.이는 일반적으로 고려 사항이 될 가능성이 높은 것은 아니지만, 결정되지 않은 수의 열에 있는 값을 서로 곱하면 많은 결과가 빠르게 생성될 수 있습니다.1,048,576 행을 초과하는 것은 예측할 수 없는 일이 아닙니다.
나열된 테이블의 모든 조합 결과의 데카르트 곱을 반환하는 비조인 선택 SQL 문의 전형적인 예입니다.
SQL 데이터베이스 솔루션
Fruit, 테이블로, SQLite, MySQL 되며 Implicit("Animals, Fruit, Country")을 을 가져올 수 .WHERE및 명시적입니다.JOIN 조인:
SELECT Animals.Animal, Fruits.Fruit, Countries.Country
FROM Animals, Countries, Fruits;
Excel 솔루션
동물, 국가 및 과일 범위가 포함된 워크북에 대한 ODBC 연결을 사용하여 VBA에서 비조인 SQL 문을 실행하는 경우와 동일한 개념입니다.예를 들어, 각 데이터 그룹은 동일한 이름의 워크시트에 있습니다.
Sub CrossJoinQuery()
Dim conn As Object
Dim rst As Object
Dim sConn As String, strSQL As String
Set conn = CreateObject("ADODB.Connection")
Set rst = CreateObject("ADODB.Recordset")
sConn = "Driver={Microsoft Excel Driver (*.xls, *.xlsx, *.xlsm, *.xlsb)};" _
& "DBQ=C:\Path To\Excel\Workbook.xlsx;"
conn.Open sConn
strSQL = "SELECT * FROM [Animals$A1:A3], [Fruits$A1:A3], [Countries$A1:A3] "
rst.Open strSQL, conn
Range("A1").CopyFromRecordset rst
rst.Close
conn.Close
Set rst = Nothing
Set conn = Nothing
End Sub
이 문제에 대한 저의 첫 번째 접근 방식은 @Jeeped가 게시한 것과 유사했습니다.
- 입력 열을 배열에 로드하고 각 열의 행 수를 계산합니다.
- 배열을 모든 조합으로 채우기
- 출력 범위에 어레이 할당
MicroTimer를 사용하여 위 알고리즘의 각 부분에서 걸리는 평균 시간을 계산했습니다.파트 3은 더 큰 입력 데이터에 대해 총 실행 시간의 90%~93%를 차지했습니다.
다음은 워크시트에 데이터를 쓰는 속도를 향상시키기 위한 시도입니다. 상를정습니다했의수▁a를 했습니다.iMinRSize=17 다이 을상 채수있 이상을 수 됩니다.iMinRSize같은 값을 가진 연속된 행은 배열 파일링을 중지하고 워크시트 범위에 직접 씁니다.
Sub CrossJoin(rSrc As Range, rTrg As Range)
Dim vSrc() As Variant, vTrgPart() As Variant
Dim iLengths() As Long
Dim iCCnt As Integer, iRTrgCnt As Long, iRSrcCnt As Long
Dim i As Integer, j As Long, k As Long, l As Long
Dim iStep As Long
Const iMinRSize As Long = 17
Dim iArrLastC As Integer
On Error GoTo CleanUp
Application.ScreenUpdating = False
Application.EnableEvents = False
vSrc = rSrc.Value2
iCCnt = UBound(vSrc, 2)
iRSrcCnt = UBound(vSrc, 1)
iRTrgCnt = 1
iArrLastC = 1
ReDim iLengths(1 To iCCnt)
For i = 1 To iCCnt
j = iRSrcCnt
While (j > 0) And IsEmpty(vSrc(j, i))
j = j - 1
Wend
iLengths(i) = j
iRTrgCnt = iRTrgCnt * iLengths(i)
If (iRTrgCnt < iMinRSize) And (iArrLastC < iCCnt) Then iArrLastC = iArrLastC + 1
Next i
If (iRTrgCnt > 0) And (rTrg.row + iRTrgCnt - 1 <= rTrg.Parent.Rows.Count) Then
ReDim vTrgPart(1 To iRTrgCnt, 1 To iArrLastC)
iStep = 1
For i = 1 To iArrLastC
k = 0
For j = 1 To iRTrgCnt Step iStep
k = k + 1
If k > iLengths(i) Then k = 1
For l = j To j + iStep - 1
vTrgPart(l, i) = vSrc(k, i)
Next l
Next j
iStep = iStep * iLengths(i)
Next i
rTrg.Resize(iRTrgCnt, iArrLastC) = vTrgPart
For i = iArrLastC + 1 To iCCnt
k = 0
For j = 1 To iRTrgCnt Step iStep
k = k + 1
If k > iLengths(i) Then k = 1
rTrg.Resize(iStep).Offset(j - 1, i - 1).Value2 = vSrc(k, i)
Next j
iStep = iStep * iLengths(i)
Next i
End If
CleanUp:
Application.ScreenUpdating = True
Application.EnableEvents = False
End Sub
Sub test()
CrossJoin Range("a2:f10"), Range("k2")
End Sub
우리가 설정하면,iMinRSizeRows.Count모든 데이터가 배열에 기록됩니다.결과입니다.
행 수가 가장 많은 입력 열이 먼저 와야 코드가 가장 잘 작동하지만, 열을 순위로 지정하고 올바른 순서로 처리하도록 코드를 수정하는 것은 큰 문제가 되지 않습니다.
워크시트 공식을 사용하여 이 작업을 수행할 수 있습니다.NAME'd 범위(동물, 과일 및 국가)가 있는 경우 "트릭"은 해당 배열에 인덱스를 생성하여 모든 다양한 조합을 제공하는 것입니다.
예:
=CEILING(ROWS($1:1)/(ROWS(Fruits)*ROWS(Countries)),1)
에서는 과일 * 국가의 숫자 항목에 대해 반복되는 1 기반 일련의 숫자를 생성합니다. 이 숫자는 각 동물에 대해 필요한 행 수를 제공합니다.
=MOD(CEILING(ROWS($1:1)/ROWS(Countries),1)-1,ROWS(Fruits))+1
국가 수에 대해 각 과일을 반복하는 1 기반 시리즈를 생성합니다.
=MOD(ROWS($1:1)-1,ROWS(Countries))+1))
1..n의 반복 시퀀스를 생성합니다. 여기서 n은 국가 수입니다.
공식화(일부 오류 확인 포함)
D3: =IFERROR(INDEX(Animals,CEILING(ROWS($1:1)/(ROWS(Fruits)*ROWS(Countries)),1)),"")
E3: =IF(E3="","",INDEX(Fruits,MOD(CEILING(ROWS($1:1)/ROWS(Countries),1)-1,ROWS(Fruits))+1))
F3: =IF(E3="","",INDEX(Countries,MOD(ROWS($1:1)-1,ROWS(Countries))+1))
사실, 저는 제 예전 답변을 수정하고 싶습니다.하지만, 저의 새로운 대답은 예전의 대답과 완전히 다릅니다.오래된 답은 특정 열에 대한 것이고 이 답은 범용 열에 대한 것이기 때문입니다.질문자는 오래된 답변에 대답한 후 보편적으로 하고 싶은 새로운 요구사항을 말합니다.고정 기둥에 대해서는 고정 루핑을 생각할 수 있고 무한 기둥에 대해서는 다른 방법으로 생각할 필요가 있습니다.그래서 저도 합니다.그리고 SO 사용자들도 코드 차이를 볼 수 있고, 이것은 초보자들에게 도움이 될 것이라고 생각합니다.
이 새로운 코드는 이전 코드처럼 그렇게 간단하지 않습니다.코드에 대해 명확하게 알고 싶다면 코드를 한 줄씩 디버그하는 것을 제안했습니다.
코드에 대해서는 걱정하지 마세요.저는 이미 그것에 대해 단계별로 테스트했습니다.저한테 딱 맞습니다.만약 당신이 아니라면, 저에게 알려주세요.한 가지는 이 코드가 빈 행(데이터가 없는 행)에 오류를 일으킬 수 있다는 것입니다.왜냐하면, 현재, 저는 그것에 대한 확인을 추가하지 않았기 때문입니다.
당신의 문제에 대한 나의 보편적인 접근 방식은 다음과 같습니다.
Public Sub matchingCell()
Dim startRawColumn, endRawColumn, startResultColumn, endResultColumn, startRow As Integer
Dim index, row, column, containerIndex, tempIndex As Integer
Dim columnCount, totalCount, timesCount, matchingCount, tempCount As Integer
Dim isExist As Boolean
Dim arrayContainer() As Variant
'Actually, even it is for universal, we need to know start column and end column of raw data.
'And also start row. And start column for write result.
'I set them for my test data.
'You need to modify them(startRawColumn, endRawColumn, startRow, startResultColumn).
'Set the start column and end column for raw data
startRawColumn = 1
endRawColumn = 3
'Set the start row for read data and write data
startRow = 2
'Set the start column for result data
startResultColumn = 4
'Get no of raw data column
columnCount = endRawColumn - startRawColumn
'Set container index
containerIndex = 0
'Re-create array container for count of column
ReDim arrayContainer(0 To columnCount)
With Sheets("sheetname")
'Getting data from sheet
'Loop all column for getting data of each column
For column = startRawColumn To endRawColumn Step 1
'Create tempArray for column
Dim tempArray() As Variant
'Reset startRow
row = startRow
'Reset index
index = 0
'Here is one things. I looped until to blank.
'If you want anymore, you can modify the looping type.
'Don't do any changes to main body of looping.
'Loop until the cell is blank
Do While .Cells(row, column) <> ""
'Reset isExist flag
isExist = False
'Remove checking for no data
If index > 0 Then
'Loop previous data for duplicate checking
For tempIndex = 0 To index - 1 Step 1
'If found, set true to isExist and stop loop
If tempArray(tempIndex) = .Cells(row, column) Then
isExist = True
Exit For
End If
Next tempIndex
End If
'If there is no duplicate data, store data
If Not isExist Then
'Reset tempArray
ReDim Preserve tempArray(index)
tempArray(index) = .Cells(row, column)
'Increase index
index = index + 1
End If
'Increase row
row = row + 1
Loop
'Store column with data
arrayContainer(containerIndex) = tempArray
'Increase container index
containerIndex = containerIndex + 1
Next column
'Now, we got all data column including data which has no duplicate
'Show result data on sheet
'Getting the result row count
totalCount = 1
'Get result row count
For tempIndex = 0 To UBound(arrayContainer) Step 1
totalCount = totalCount * (UBound(arrayContainer(tempIndex)) + 1)
Next tempIndex
'Reset timesCount
timesCount = 1
'Get the last column for result
endResultColumn = startResultColumn + columnCount
'Loop array container
For containerIndex = UBound(arrayContainer) To 0 Step -1
'Getting the counts for looping
If containerIndex = UBound(arrayContainer) Then
duplicateCount = 1
timesCount = totalCount / (UBound(arrayContainer(containerIndex)) + 1)
Else
duplicateCount = duplicateCount * (UBound(arrayContainer(containerIndex + 1)) + 1)
timesCount = timesCount / (UBound(arrayContainer(containerIndex)) + 1)
End If
'Reset the start row
row = startRow
'Loop timesCount
For countIndex = 1 To timesCount Step 1
'Loop data array
For index = 0 To UBound(arrayContainer(containerIndex)) Step 1
'Loop duplicateCount
For tempIndex = 1 To duplicateCount Step 1
'Write data to cell
.Cells(row, endResultColumn) = arrayContainer(containerIndex)(index)
'Increase row
row = row + 1
Next tempIndex
Next index
Next countIndex
'Increase result column index
endResultColumn = endResultColumn - 1
Next containerIndex
End With
End Sub
여기 재귀 버전이 있습니다.코어 함수가 탭으로 구분된 제품 문자열을 반환하기 때문에 데이터에 내부 탭이 없는 것으로 가정합니다.주 서브는 출력 범위의 왼쪽 상단 모서리 셀과 함께 데이터로 구성된 범위를 통과해야 합니다.이것은 아마도 약간 조정될 수 있지만 테스트 목적에 적합합니다.
ColumnProducts Range("A:C"), Range("E1")
OP 문제를 해결하는 통화입니다.코드는 다음과 같습니다.
'the following function takes a collection of arrays of strings
'and returns a variant array of tab-delimited strings which
'comprise the (tab-delimited) cartesian products of
'the arrays in the collection
Function CartesianProduct(ByVal Arrays As Collection) As Variant
Dim i As Long, j As Long, k As Long, m As Long, n As Long
Dim head As Variant
Dim tail As Variant
Dim product As Variant
If Arrays.Count = 1 Then
CartesianProduct = Arrays.Item(1)
Exit Function
Else
head = Arrays.Item(1)
Arrays.Remove 1
tail = CartesianProduct(Arrays)
m = UBound(head)
n = UBound(tail)
ReDim product(1 To m * n)
k = 1
For i = 1 To m
For j = 1 To n
product(k) = head(i) & vbTab & tail(j)
k = k + 1
Next j
Next i
CartesianProduct = product
End If
End Function
Sub ColumnProducts(data As Range, output As Range)
Dim Arrays As New Collection
Dim strings As Variant, product As Variant
Dim i As Long, j As Long, n As Long, numRows As Long
Dim col As Range, cell As Range
Dim outRange As Range
numRows = Range("A:A").Rows.Count
For Each col In data.Columns
n = col.EntireColumn.Cells(numRows).End(xlUp).Row
i = col.Cells(1).Row
ReDim strings(1 To n - i + 1)
For j = 1 To n - i + 1
strings(j) = col.Cells(i + j - 1)
Next j
Arrays.Add strings
Next col
product = CartesianProduct(Arrays)
n = UBound(product)
Set outRange = Range(output, output.Offset(n - 1))
outRange.Value = Application.WorksheetFunction.Transpose(product)
outRange.TextToColumns Destination:=output, DataType:=xlDelimited, Tab:=True
End Sub
좋아요, 그럼 당신은 가능한 모든 조합의 목록을 원하는 거군요.제가 할 일은 다음과 같습니다.
- 먼저 원시 데이터를 선택하고 열별로 중복 항목을 제거합니다.
- 그런 다음 이 세 개의 열을 세 개의 개별 배열로 읽습니다.
- 모든 배열의 총 길이를 계산합니다.
- 그런 다음 루프 페이스트를 사용하여 국가 배열의 첫 번째 값을 동물과 과일의 조합 수만큼 반복해서 배열의 길이를 늘렸습니다.
- 루프 안에서 모든 과일 옵션을 게시하는 또 다른 루프를 만듭니다.최대 동물 수와 동일한 중복 행 수를 사용합니다.
- 그런 다음 표의 마지막 행까지 서로 따라붙지 않고 동물을 붙여넣습니다.
여기, 당신의 문제에 대한 나의 접근법.
Public Sub matchingCell()
Dim animalRow, fruitRow, countryRow, checkRow, resultRow As Long
Dim isExist As Boolean
'Set the start row
animalRow = 2
resultRow = 2
'Work with data sheet
With Sheets("sheetname")
'Loop until animals column is blank
Do While .Range("A" & animalRow) <> ""
'Set the start row
fruitRow = 2
'Loop until fruits column is blank
Do While .Range("B" & fruitRow) <> ""
'Set the start row
countryRow = 2
'Loop until country column is blank
Do While .Range("C" & countryRow) <> ""
'Set the start row
checkRow = 2
'Reset flag
isExist = False
'Checking for duplicate row
'Loop all result row until D is blank
Do While .Range("D" & checkRow) <> ""
'If duplicate row found
If .Range("D" & checkRow) = .Range("A" & animalRow) And _
.Range("E" & checkRow) = .Range("B" & fruitRow) And _
.Range("F" & checkRow) = .Range("C" & countryRow) Then
'Set true for exist flag
isExist = True
End If
checkRow = checkRow + 1
Loop
'If duplicate row not found
If Not isExist Then
.Range("D" & resultRow) = .Range("A" & animalRow)
.Range("E" & resultRow) = .Range("B" & fruitRow)
.Range("F" & resultRow) = .Range("C" & countryRow)
'Increase resultRow
resultRow = resultRow + 1
End If
'Increase countryRow
countryRow = countryRow + 1
Loop
'Increase fruitRow
fruitRow = fruitRow + 1
Loop
'Increase fruitRow
animalRow = animalRow + 1
Loop
End With
End Sub
이미 테스트해 봤어요.잘 작동합니다.좋은 하루 되세요.
먼저 다음과 같이 데이터를 입력해야 합니다.데이터 저장 방법
주파수를 함께 추가할 새 열을 추가합니다.간단한 재귀 공식을 수행합니다.(예: f3+f4)
최신 버전의 Excel과 새로운 기능 Xlookup으로 가져가기 위해, 저는 다음 공식을 제안합니다: =XLOOKUP(ROWS(K$2[a]:K2), $I$3:$I$8[b], $H$3:$H$8[c]"모든 주파수 충족", 1,1
위치:
데이터를 표시할 열입니다.번호를 잠그는 것이 중요합니다.
주파수가 함께 추가된 것입니까?
해당 주파수에서 표시할 요소입니다.
작동 방식:
ROWS(K$2[a]:K2) : 컬럼의 위치를 결정합니다.첫 번째 셀에서는 첫 번째 위치에서 자신을 고려합니다.다음 셀은 두 번째 셀이 될 것입니다.
XLOOKUP 파트: 위치가 확보되면 ROWS()에서 발견된 위치가 첫 번째 주파수보다 낮거나 같은지(왜 첫 번째 주파수를 사용하는지) 비교합니다.
이 경우 해당 주파수와 관련된 요소가 표시됩니다.
첫 번째 주파수보다 크면 두 번째 주파수 등을 확인합니다.
최대 결합 주파수보다 먼 경우 "모든 주파수 충족"으로 표시됩니다.
마지막 1은 이 기능에 필요하지 않습니다.
언급URL : https://stackoverflow.com/questions/31472816/expanding-column-cells-for-each-column-cell
'programing' 카테고리의 다른 글
| 'id'는 Python에서 잘못된 변수 이름입니다. (0) | 2023.06.24 |
|---|---|
| Mongodb 데이터베이스 노드 모의/테스트.js (0) | 2023.06.24 |
| 사용자 정의 함수가 재계산되지 않음 (0) | 2023.06.24 |
| 다른 사람이 먼저 제기할 때의 예외가 무슨 효과가 있습니까? (0) | 2023.06.24 |
| "error": "Index not defined, add.indexOn" (0) | 2023.06.24 |