귀하의 프로필에 프로그램이 나와 있으므로 VBA 구문을 모른다는 것이 문제라고 생각됩니다. 나는 당신의 테이블에 대한 가정을했다. 그러나 나의 가정이 틀렸다면 당신이 나의 코드를 수정할 수 있다고 가정한다.
워크 시트 TblSrc에 데이터 복사본을 만들었습니다.
표 1 :
표 2 : I는 각 기본 테이블에 팔 개 하위 테이블이 때문에
나는 이러한 행을 중복. 이 코드는 두 개의 주 테이블간에 일대일로 일치하는 것이 중요합니다. 두 개의 하위 테이블이 일치하는지 확인하지 않습니다.
내가 의해 하이픈의 라인을 만들어 : 이것은 가치가 무엇인지 실제 타이밍뿐만에 대한 충분한 데이터가 아닌, 아래 매크로 하위 테이블 네 쌍의 생성을 복사 0.03 초 걸렸습니다 셀을 병합하고, 첫 번째 값을 '-'로 설정하고 가로 정렬을 채우기로 설정합니다. 하이픈 인 열 A의 첫 번째 문자를 확인하여 구분 기호 행을 식별합니다. 하이픈 앞의 작은 따옴표는 유효하지 않은 음수처럼 보이지 않게합니다. 셀 값의 일부가 아닙니다.
이 매크로는이 문제에 대한 가장 빠른 방법은 아니지만 하위 테이블의 모든 서식을 원본에서 대상으로 복사합니다.
매크로 내에 몇 가지 의견이 있지만 충분하지 않을 수 있습니다. F5 (다음 중단 점까지 실행) 및 F8 (다음 명령문 실행)으로 매크로를 단계별로 실행하는 것이 좋습니다.
질문으로 돌아 오면 개선 할 답변을드립니다. 데이터에 대한 더 많은 정보를 제공 할 수 있다면 다른 접근법을 보여줄 수도 있습니다.
경고 21:45 여기에 있으며 내일 인터넷 접속에 대한 확신이 없습니다. 가능한 한 빨리 질문에 답변 해 드리겠습니다.
명시 적 옵션 하위 CombineTables는()
Dim CellValue() As Variant
Dim ColCrnt As Long
Dim ColMax As Long
Dim Found As Boolean
Dim RngStgHeader1 As String
Dim RngStgHeader2 As String
Dim RngStgHeaderX As String
Dim RowDestCrnt As Long
Dim RowSrcSubTab1End As Long
Dim RowSrcSubTab1Start As Long
Dim RowSrcSubTab2End As Long
Dim RowSrcSubTab2Start As Long
Dim RowSrcTab1Crnt As Long
Dim RowSrcTab2Crnt As Long
Dim RowSrcTab1End As Long
Dim RowSrcTab1Start As Long
Dim RowSrcTab2End As Long
Dim RowSrcTab2Start As Long
Dim timeStart As Double
Application.EnableEvents = False ' Prevents any event routine being called
Application.ScreenUpdating = False ' Screen updating causes flicker and is slow
timeStart = Timer ' Seconds since midnight
' Gather information from source worksheet
With Worksheets("TblSrc")
' These statements find the last row and the last column containing a value
RowSrcTab2End = .Cells.Find("*", .Range("A1"), xlFormulas, , _
xlByRows, xlPrevious).Row
ColMax = .Cells.Find("*", .Range("A1"), xlFormulas, , _
xlByColumns, xlPrevious).Column
CellValue = .Range(.Cells(1, 1), .Cells(RowSrcTab2End, ColMax)).Value
' CellValue is now a 2D array containing every value from the used range.
' The first dimension will be for the rows and the second for the columns.
' The lower bound of each dimension will be 1. The upper bounds will be
' RowSrcTab2End and ColMax. Having the rows as the first dimension is
' unusual is the nature of arrays loaded from or to a worksheet.
' I did not have to copy the data to an array. I could have done so
' because I believe searching for sub tables will be sufficiently faster
' to make this a sensible choice.
End With
' Find the start of the main tables.
For RowSrcTab1Crnt = 1 To RowSrcTab2End
If CellValue(RowSrcTab1Crnt, 1) = "projectId" And _
CellValue(RowSrcTab1Crnt, 2) = "start" Then
RowSrcTab1Start = RowSrcTab1Crnt
Exit For
End If
Next
For RowSrcTab2Crnt = RowSrcTab1Crnt + 1 To RowSrcTab2End
If CellValue(RowSrcTab2Crnt, 1) = "projectId" And _
CellValue(RowSrcTab2Crnt, 2) = "expenseCode" Then
RowSrcTab2Start = RowSrcTab2Crnt
Exit For
End If
Next
RowSrcTab1End = RowSrcTab2Start - 1
' Output values found to the Immediate window as a check
Debug.Print "Table 1 rows: " & RowSrcTab1Start & " - " & RowSrcTab1End
Debug.Print "Table 2 rows: " & RowSrcTab2Start & " - " & RowSrcTab2End
With Worksheets("TblDest")
' Clear current contents of destination sheet
.Cells.EntireRow.Delete
End With
' Build range strings for table headers because
' they are needed for every projectId
RngStgHeader1 = "A" & RowSrcTab1Start & ":" & _
ColNumToCode(ColMax) & RowSrcTab1Start
RngStgHeader2 = "A" & RowSrcTab2Start & ":" & _
ColNumToCode(ColMax) & RowSrcTab2Start
RowSrcTab1Crnt = RowSrcTab1Start + 1 ' \ Start point for search
RowSrcTab2Crnt = RowSrcTab2Start + 1 '/for first sub tables
RowDestCrnt = 1 ' Position for first output sub tables
Do While True
' Search for start of next sub table 1
Found = False
Do While RowSrcTab1Crnt < RowSrcTab2Start
If CellValue(RowSrcTab1Crnt, 1) <> "" And _
Left(CellValue(RowSrcTab1Crnt, 1), 1) <> "-" Then
' Assume next table 1 row with column A not empty and not starting
' with a hyphen is the start of next table 1 sub table
Found = True
RowSrcSubTab1Start = RowSrcTab1Crnt
RowSrcTab1Crnt = RowSrcTab1Crnt + 1 ' Prepare for search for end
Exit Do
End If
RowSrcTab1Crnt = RowSrcTab1Crnt + 1
Loop
If Not Found Then
' No next sub table 1 found. All done.
Exit Do
End If
' Search for end of this sub table 1
Found = False
Do While RowSrcTab1Crnt < RowSrcTab2Start
If LCase(Left(CellValue(RowSrcTab1Crnt, 1), 5)) = "total" Then
Found = True
RowSrcSubTab1End = RowSrcTab1Crnt
RowSrcTab1Crnt = RowSrcTab1Crnt + 1 ' Prepare for next loop
Exit Do
End If
RowSrcTab1Crnt = RowSrcTab1Crnt + 1
Loop
If Not Found Then
' End of table not found. Either data error or program error
Debug.Assert False ' Interpreter will stop here to allow
' examination of variables
Exit Do
End If
' Search for start of next sub table 2
Found = False
Do While RowSrcTab2Crnt < RowSrcTab2End
If CellValue(RowSrcTab2Crnt, 1) <> "" And _
Left(CellValue(RowSrcTab2Crnt, 1), 1) <> "-" Then
' Assume next table 2 row with column A not empty and not starting
' with a hyphen is the start of next table 2 sub table
Found = True
RowSrcSubTab2Start = RowSrcTab2Crnt
RowSrcTab2Crnt = RowSrcTab2Crnt + 1 ' Prepare for search for end
Exit Do
End If
RowSrcTab2Crnt = RowSrcTab2Crnt + 1
Loop
If Not Found Then
' No next sub table 2 found. Have table 1 so have data or program error.
Debug.Assert False ' Interpreter will stop here to allow
' examination of variables
Exit Do
End If
' Search for end of this sub table 2
Found = False
Do While RowSrcTab2Crnt < RowSrcTab2End
If LCase(Left(CellValue(RowSrcTab2Crnt, 1), 5)) = "total" Then
Found = True
RowSrcSubTab2End = RowSrcTab2Crnt
RowSrcTab2Crnt = RowSrcTab2Crnt + 1 ' Prepare for next loop
Exit Do
End If
RowSrcTab2Crnt = RowSrcTab2Crnt + 1
Loop
If Not Found Then
' End of table not found. Either data error or program error
Debug.Assert False ' Interpreter will stop here to allow
' examination of variables
Exit Do
End If
' Have start and end of next sub tables.
' Copy header row for table 1
Worksheets("TblSrc").Range(RngStgHeader1).Copy _
Destination:=Worksheets("TblDest").Cells(RowDestCrnt, 1)
RowDestCrnt = RowDestCrnt + 1
' Copy sub table 1 plus rows before and after which should be dividing rows
RngStgHeaderX = "A" & RowSrcSubTab1Start - 1 & ":" & _
ColNumToCode(ColMax) & RowSrcSubTab1End + 1
Worksheets("TblSrc").Range(RngStgHeaderX).Copy _
Destination:=Worksheets("TblDest").Cells(RowDestCrnt, 1)
RowDestCrnt = RowDestCrnt + RowSrcSubTab1End - RowSrcSubTab1Start + 4
' Copy header row for table 2
Worksheets("TblSrc").Range(RngStgHeader2).Copy _
Destination:=Worksheets("TblDest").Cells(RowDestCrnt, 1)
RowDestCrnt = RowDestCrnt + 1
' Copy sub table 2 plus rows before and after which should be dividing rows
RngStgHeaderX = "A" & RowSrcSubTab2Start - 1 & ":" & _
ColNumToCode(ColMax) & RowSrcSubTab2End + 1
Worksheets("TblSrc").Range(RngStgHeaderX).Copy _
Destination:=Worksheets("TblDest").Cells(RowDestCrnt, 1)
RowDestCrnt = RowDestCrnt + RowSrcSubTab2End - RowSrcSubTab2Start + 3
' Warning there is a limit of 1026 on the number of horizontal page breaks
Worksheets("TblDest").HPageBreaks.Add _
Before:=Worksheets("TblDest").Cells(RowDestCrnt, 1)
Loop
Debug.Print Timer - timeStart
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
Function ColNumToCode(ByVal ColNum As Long) As String
' Convert column number (such as 1, 2, 27, etc.) to
' column code (such as A, B, AA, etc.)
Dim Code As String
Dim PartNum As Long
' Last updated 3 Feb 12. Adapted to handle three character codes.
If ColNum = 0 Then
ColNumToCode = "0"
Else
Code = ""
Do While ColNum > 0
PartNum = (ColNum - 1) Mod 26
Code = Chr(65 + PartNum) & Code
ColNum = (ColNum - PartNum - 1) \ 26
Loop
End If
ColNumToCode = Code
End Function
당신은 데이터의 더미 샘플 세트에 대한 링크를 게시 할 수 있습니까? –
불행히도, 아니요. :/ – Kraz
동일한 프로젝트 ID가 두 테이블에 동일한 순서로 표시됩니까? 그렇지 않은 경우 projectIds가 오름차순으로 나열되어 있으므로 누락 된 경우 올바른 작업을 결정할 수 있습니까? 이 과정을 오래 걸리지 않아야합니다 (8 시간 미만) 또는 VBA로 실행해야합니까? –