- vlookup
Code: Select all
Sub Make_K_table()
'
' Make_K_table Macro
'
'
Dim i As Integer
Dim j As Integer
Dim R1 As Integer
Dim C1 As Integer
Dim R2 As Integer
Dim C2 As Integer
Dim maxRow1 As Integer
Dim maxRow2 As Integer
Dim tgtCol As Integer
Dim tgtCo2 As Integer
Dim sheetK As String
Dim sheetKno As String
Dim sheetKdb As String
Dim sheetKgp As String
Dim sheetSdb As String
'*********************************************************
sheetK = "K-Table"
sheetKno = "K_RCLzoneNo_Template"
sheetKdb = "K-DB_Template"
sheetKgp = "K-zone-Groups"
sheetSdb = "S-DB_Template"
'*********************************************************
' Find a list of unique K zone numbers, used in the model.
Worksheets(sheetKno).Activate ' same as Sheets(sheetKno).Select
Columns("L:L").Clear
Columns("E:E").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Columns( _
"L:L"), Unique:=True
Columns("L:L").Select
Worksheets(sheetKno).Sort.SortFields.Clear
Worksheets(sheetKno).Sort.SortFields.Add Key:=Range _
("L1:L500"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortNormal
With ActiveWorkbook.Worksheets(sheetKno).Sort
.SetRange Range("L1:L500")
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Range("L1").Select
maxRow1 = Sheets(sheetKno).Cells(Sheets(sheetKno).Rows.Count, 12).End(xlUp).Row
If Sheets(sheetKno).Cells(1, 12) = Sheets(sheetKno).Cells(1, 12) Then
Sheets(sheetKno).Cells(4, 11) = maxRow1 - 1
Sheets(sheetKno).Cells(1, 12).Clear
Sheets(sheetKno).Cells(1, 12) = "K no"
Else
Sheets(sheetKno).Cells(4, 11) = maxRow1
End If
' Calculate Group ID (i.e., Last two digits of K zone number).
Sheets(sheetKno).Cells(1, 13) = "Group ID"
For i = 2 To maxRow1
Sheets(sheetKno).Cells(i, 13) = Sheets(sheetKno).Cells(i, 12) Mod 100
Next i
' Unique Group ID
Columns("O:O").Clear
Range("O1") = "Unique Group ID"
Range("M2:M500").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range( _
"O2:O500"), Unique:=True
Columns("O:O").Select
Worksheets(sheetKno).Sort.SortFields.Clear
Worksheets(sheetKno).Sort.SortFields.Add Key:=Range _
("O2:O500"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortNormal
With ActiveWorkbook.Worksheets(sheetKno).Sort
.SetRange Range("O2:O500")
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
' Copy ans sort Group ID and K zone no.
Range("M3:M500").Select ' Exclude K zone number "1"
Selection.Copy
Range("Q2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("L3:L500").Select ' Exclude K zone number "1"
Selection.Copy
Range("R2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
' Sort K zone no based on Group ID.
Columns("Q:R").Select
ActiveWorkbook.Worksheets(sheetKno).Sort.SortFields.Clear
ActiveWorkbook.Worksheets(sheetKno).Sort.SortFields.Add Key:= _
Range("Q2:Q500"), SortOn:=xlSortOnValues, Order:=xlAscending, _
DataOption:=xlSortNormal
ActiveWorkbook.Worksheets(sheetKno).Sort.SortFields.Add Key:= _
Range("R2:R500"), SortOn:=xlSortOnValues, Order:=xlAscending, _
DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets(sheetKno).Sort
.SetRange Range("Q1:R500")
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
' Clear the spaces for K values.
Sheets(sheetK).Select
Range("B4:H504").Clear
' Copy Group ID and K zone no. into sheet "K-Table"
Sheets(sheetKno).Select
Range("Q2:R500").Select
Selection.Copy
Sheets(sheetK).Select
Range("C4").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("G4").Select
' Color Rows for each K groups
maxRow2 = Sheets(sheetK).Cells(Sheets(sheetK).Rows.Count, 3).End(xlUp).Row
groupIDx = Sheets(sheetK).Cells(4, 3)
colorCodeX = xlThemeColorAccent5
For i = 4 To maxRow2
If groupIDx = Sheets(sheetK).Cells(i, 3) Then
Else
groupIDx = Sheets(sheetK).Cells(i, 3)
If colorCodeX = xlThemeColorAccent5 Then
colorCodeX = xlThemeColorAccent6
Else
colorCodeX = xlThemeColorAccent5
End If
End If
Range(Cells(i, 3), Cells(i, 8)).Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = colorCodeX
.TintAndShade = 0.799981688894314
.PatternTintAndShade = 0
End With
Next i
' Group Name and draw bottom line for each group.
maxRow2 = Sheets(sheetK).Cells(Sheets(sheetK).Rows.Count, 3).End(xlUp).Row
j = 1
minGpID = Sheets(sheetKgp).Cells(j + 1, 4)
maxGpID = Sheets(sheetKgp).Cells(j + 1, 5)
Sheets(sheetK).Cells(4, 2) = Sheets(sheetKgp).Cells(j + 1, 3)
Sheets(sheetK).Cells(5, 2) = Sheets(sheetKgp).Cells(j + 1, 6)
For i = 5 To maxRow2
groupIDx = Sheets(sheetK).Cells(i, 3)
If groupIDx > maxGpID Then
j = j + 1
Sheets(sheetK).Cells(i, 2) = Sheets(sheetKgp).Cells(j + 1, 3) ' Name of Hydrogeologic Unit.
Sheets(sheetK).Cells(i + 1, 2) = Sheets(sheetKgp).Cells(j + 1, 6) ' Name of Hydrogeologic Unit.
maxGpID = Sheets(sheetKgp).Cells(j + 1, 5)
Sheets(sheetK).Range(Cells(i, 2), Cells(i, 8)).Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
Selection.Borders(xlEdgeLeft).LineStyle = xlNone
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
Selection.Borders(xlEdgeBottom).LineStyle = xlNone
Selection.Borders(xlEdgeRight).LineStyle = xlNone
Selection.Borders(xlInsideVertical).LineStyle = xlNone
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
End If
Next i
' Draw double line at the bottom
maxRow2 = Sheets(sheetK).Cells(Sheets(sheetK).Rows.Count, 3).End(xlUp).Row
i = maxRow2
Sheets(sheetK).Range(Cells(i, 2), Cells(i, 8)).Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
Selection.Borders(xlEdgeLeft).LineStyle = xlNone
Selection.Borders(xlEdgeTop).LineStyle = xlNone
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlDouble
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThick
End With
Selection.Borders(xlEdgeRight).LineStyle = xlNone
Selection.Borders(xlInsideVertical).LineStyle = xlNone
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
' Clean Group ID
maxRow2 = Sheets(sheetK).Cells(Sheets(sheetK).Rows.Count, 3).End(xlUp).Row
groupIDx = Sheets(sheetK).Cells(4, 3)
For i = 5 To maxRow2
If groupIDx = Sheets(sheetK).Cells(i, 3) Then
Sheets(sheetK).Cells(i, 3).ClearContents
Else
groupIDx = Sheets(sheetK).Cells(i, 3)
End If
Next i
' Update Kh and Kv values
maxRow2 = Sheets(sheetK).Cells(Sheets(sheetK).Rows.Count, 4).End(xlUp).Row
For i = 4 To maxRow2
kID = Sheets(sheetK).Cells(i, 4) ' Kh
Sheets(sheetK).Cells(i, 5) = WorksheetFunction.VLookup(kID, _
Sheets(sheetKdb).Range("B3:F502"), 2, False)
Sheets(sheetK).Cells(i, 6) = WorksheetFunction.VLookup(kID, _
Sheets(sheetKdb).Range("B3:F502"), 4, False)
Sheets(sheetK).Cells(i, 5).NumberFormat = "0.00E+00"
Sheets(sheetK).Cells(i, 6).NumberFormat = "0.00E+00"
Next i
' Update Sy and Ss values
maxRow2 = Sheets(sheetK).Cells(Sheets(sheetK).Rows.Count, 4).End(xlUp).Row
For i = 4 To maxRow2
kID = Sheets(sheetK).Cells(i, 4) ' Kh
Sheets(sheetK).Cells(i, 7) = WorksheetFunction.VLookup(kID, _
Sheets(sheetSdb).Range("B3:F502"), 3, False)
Sheets(sheetK).Cells(i, 8) = WorksheetFunction.VLookup(kID, _
Sheets(sheetSdb).Range("B3:F502"), 2, False)
Sheets(sheetK).Cells(i, 7).NumberFormat = "0.00E+00"
Sheets(sheetK).Cells(i, 8).NumberFormat = "0.00E+00"
If Sheets(sheetK).Cells(i, 7) = 0 Or Sheets(sheetK).Cells(i, 8) = 0 Then
Sheets(sheetK).Cells(i, 7) = "-" ' .ClearContents
Sheets(sheetK).Cells(i, 8) = "-" '.ClearContents
Sheets(sheetK).Cells(i, 7).HorizontalAlignment = xlRight
Sheets(sheetK).Cells(i, 8).HorizontalAlignment = xlRight
End If
Next i
Sheets(sheetK).Select
Range("I4").Select
End Sub