Excel表格的布局
问题:
我必须从两张纸的第一列中找到所有字符串的超集。这些可以存在于一张或两张纸中。根据存在的字符串,将该字符串复制到第三个工作表。然后从一个或两个工作表中复制下一列中的数据。然后找出差异。重复。如果两个工作表中都存在字符串,则此代码有效。如果第一列中的字符串不存在于一个或两个中,我如何使其工作?我想要包括两张表中的所有数据。
这是代码:
Sub Macro5()
'
' Macro5 Macro
'
'
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim ws3 As Worksheet
Dim coli As Double
Dim Coli3 As Double
Dim rowy As Double
Dim numCols As Double
Dim startRow As Double
Dim lastRow As Double
Dim dict As Scripting.Dictionary
startRow = 6 'assuming data starts here
Coli3 = 2 ' start the columns out on ws3
Set ws1 = ThisWorkbook.Worksheets("sheet1")
Set ws2 = ThisWorkbook.Worksheets("sheet2")
Set ws3 = ThisWorkbook.Worksheets("sheet3")
Application.ScreenUpdating = False
ws3.Cells.Clear
'ws1.Range("A1").EntireColumn.Copy Destination:=ws3.Range("A1")
'Find how many columns there are in sheet1 based on data in row 1
numCols = ws1.Cells(7, Columns.Count).End(xlToLeft).Column
For coli = 2 To numCols
'Find last Data row in the given column in sheet1
lastRow = ws1.Cells(ws1.Rows.Count, coli).End(xlUp).Row
For rowy = 6 To lastRow
'perform calculation and place in the right spot on sheet 3
If rowy = "6" Then
ws3.Cells(rowy, Coli3) = ws1.Cells(rowy, coli) & "-sheet1" ' copy sheet 1 to the right spot of sheet 3
ws3.Cells(rowy, Coli3 + 1) = ws2.Cells(rowy, coli) & "-sheet2" 'copy sheet 2 to the right spot of sheet 3
ws3.Cells(rowy, Coli3 + 2) = "Difference"
Else
If ws1.Cells(rowy, 1) = ws2.Cells(rowy, 1) Then
ws3.Cells(rowy, 1) = ws1.Cells(rowy, 1)
ws3.Cells(rowy, Coli3) = Format(ws1.Cells(rowy, coli).Value, "#,##0") ' copy sheet 1 to the right spot of sheet 3
ws3.Cells(rowy, Coli3 + 1) = Format(ws2.Cells(rowy, coli).Value, "#,##0") 'copy sheet 2 to the right spot of sheet 3
ws3.Cells(rowy, Coli3 + 2) = Format((ws1.Cells(rowy, coli).Value) - (ws2.Cells(rowy, coli).Value), "#,##0")
Else
ws3.Cells(rowy, 1) = ws1.Cells(rowy, 1)
ws3.Cells(rowy, Coli3) = Format(ws1.Cells(rowy, coli).Value, "#,##0") ' copy sheet 1 to the right spot of sheet 3
ws3.Cells(rowy, Coli3 + 1).Value = 0 'copy sheet 2 to the right spot of sheet 3
ws3.Cells(rowy, Coli3 + 2) = Format((ws1.Cells(rowy, coli).Value) - (ws2.Cells(rowy, coli).Value), "#,##0")
End If
End If
Next rowy ' move to the next row on ws1, ws2, ws3
'Since we are placing 3 cols at a time in sheet 3 we increment differently
Coli3 = Coli3 + 3 '1 becomes 4, 4 becomes 7, 7 becomes 10 and so on
Next coli 'move to next column on ws1, ws2
End Sub
请协助。
试试看。策略是在缓冲区中收集所有唯一的字符串值,并将它们的行值存储在索引缓冲区中(假设一个字符串在一个工作表上只出现一次)。然后从索引缓冲区中获取所有行值,并将该行中的值复制到ws3。 N.B。:我将循环类型和lastrow计数器替换为long。
Sub Macro5()
'
' Macro5 Macro
'
'
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim ws3 As Worksheet
Dim coli As Long
Dim Coli3 As Long
Dim rowy As Long
Dim numCols As Long
Dim lastRow1 As Long ' last row on sheet1 in the actual data column
Dim lastRow2 As Long ' last row on sheet2 in the actual data column
Dim r1stSheet As Range ' string column range on sheet1
Dim r2ndSheet As Range ' string column range on sheet2
Dim rFnd As Range ' aux for search
Const MAXROW = 100 ' max number of rows
Const HDRROW = 6 ' row where the header is
Dim aStr(1 To MAXROW) As String ' strings in col1
Dim aNdx(1 To MAXROW, 1 To 2) As Long ' col1: row on sheet1 or 0, col2: row on sheet2 or 0
Dim iCnt As Long ' last valid entry in aNdx
' Dim dict As Scripting.Dictionary
startRow = 6 'assuming data starts here
Coli3 = 2 ' start the columns out on ws3
Set ws1 = ThisWorkbook.Worksheets("sheet1")
Set ws2 = ThisWorkbook.Worksheets("sheet2")
Set ws3 = ThisWorkbook.Worksheets("sheet3")
' Application.ScreenUpdating = False
ws3.Cells.Clear
' make a unique list of all strings on sheet1 and sheet2
lastRow1 = ws1.Cells(ws1.Rows.Count, 1).End(xlUp).Row
lastRow2 = ws2.Cells(ws2.Rows.Count, 1).End(xlUp).Row
Set r1stSheet = Range(ws1.Cells(6, 1), ws1.Cells(lastRow1, 1))
Set r2ndSheet = Range(ws2.Cells(6, 1), ws2.Cells(lastRow2, 1))
iCnt = 0
For rowy = HDRROW + 1 To lastRow1 ' process sheet1 against sheet2
If ws1.Cells(rowy, 1) <> vbNullString Then
iCnt = iCnt + 1
Set rFnd = r2ndSheet.Find(What:=ws1.Cells(rowy, 1), LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlRows, SearchDirection:=xlNext, MatchCase:=False)
aStr(iCnt) = ws1.Cells(rowy, 1)
aNdx(iCnt, 1) = rowy
If rFnd Is Nothing Then ' not found matching string
aNdx(iCnt, 2) = 0
Else ' match found
aNdx(iCnt, 2) = rFnd.Row
End If
End If
Next rowy ' on sheet1
For rowy = HDRROW + 1 To lastRow2 ' process sheet2 against sheet1: find nonmatching values
If ws2.Cells(rowy, 1) <> vbNullString Then
Set rFnd = r1stSheet.Find(What:=ws2.Cells(rowy, 1), LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlRows, SearchDirection:=xlNext, MatchCase:=False)
If rFnd Is Nothing Then ' not found matching string
iCnt = iCnt + 1
aStr(iCnt) = ws2.Cells(rowy, 1)
aNdx(iCnt, 1) = 0
aNdx(iCnt, 2) = rowy
End If
End If
Next rowy ' on sheet2
rFnd = Nothing
For i = 1 To iCnt
ws3.Cells(i + HDRROW, 1) = aStr(i) ' strings
Next i
'Find how many columns there are in sheet1 based on data in row 1
numCols = ws1.Cells(HDRROW + 1, Columns.Count).End(xlToLeft).Column
For coli = 2 To numCols
ws3.Cells(HDRROW, Coli3) = "sheet1" ' copy sheet 1 to the right spot of sheet 3
ws3.Cells(HDRROW, Coli3 + 1) = "sheet2" 'copy sheet 2 to the right spot of sheet 3
ws3.Cells(HDRROW, Coli3 + 2) = "Difference"
For i = 1 To iCnt
If aNdx(i, 1) = 0 Then
ws3.Cells(i + HDRROW, Coli3) = 0
Else
ws3.Cells(i + HDRROW, Coli3) = ws1.Cells(aNdx(i, 1), coli).Value ' val1
End If
If aNdx(i, 2) = 0 Then
ws3.Cells(i + HDRROW, Coli3 + 1) = 0
Else
ws3.Cells(i + HDRROW, Coli3 + 1) = ws2.Cells(aNdx(i, 2), coli).Value ' val2
End If
ws3.Cells(i + HDRROW, Coli3 + 2) = ws3.Cells(i + HDRROW, Coli3) - ws3.Cells(i + HDRROW, Coli3 + 1) ' diff
Next i
' finished with data, format columns
Range(ws3.Cells(HDRROW + 1, Coli3), ws3.Cells(iCnt + HDRROW, Coli3 + 2)).NumberFormat = "#.##0"
'Since we are placing 3 cols at a time in sheet 3 we increment differently
Coli3 = Coli3 + 3 '1 becomes 4, 4 becomes 7, 7 becomes 10 and so on
Next coli 'move to next column on ws1, ws2
End Sub