求值换成另一个sheet补一个table
Find value into another sheet to fill a table
我有两张表，我需要获取每个人的字段名称。为此，我需要在 sheet2 中排一个人，然后我必须在右侧的 sheet1 中获取此人分配的字段 table（对于每一行）。对于这部分，我找到并修改了这段 VBA 代码，但它并没有满足我的需要……:
Dim rgFound As Range
Dim defVal As Range
Dim currParam As Range
Dim currParamDict As Range
With Worksheets("Sheet2")
For Each defVal In .Range("B3", .Range("B" & Rows.Count).End(xlUp)).Offset(, 1)
Set currParam = defVal.Offset(, -1)
If Len(currParam.Value) > 0 Then
Set rgFound = Worksheets("Sheet1").Range("F9:I12").Find(currParam.Value)
If rgFound Is Nothing Then
Debug.Print "Name was not found."
Else
Set currParamDict = rgFound.Offset(, 0)
defVal.Value = currParamDict.Value
End If
End If
Next defVal
End With
I dont know for the range in : Set rgFound = Worksheets("Sheet1").Range("F9:I12").Find(currParam.Value)
我放了一些示例图片，以便您了解它的内容。
工作表 1：
工作表 2：
完成这一步后，我必须使用 Sheet1 的左侧 table 填写与字段对应的日期...
这一行不是标识分区，而是搜索中的名称本身。更改语句以引用第 9 行中的数据。我假设位置是固定的，如果不是那么你需要另一种方法。
Set currParamDict = rgFound.Offset(, 0)
' becomes
set currParamDict = Worksheets("sheet1").Cells(9, rgFound.Column)
填一个Table
偏离轨道
- 忽略
Sheet2 中可能的旧数据并写入完整的 table。
Option Explicit
Sub FillTable()
' Source Dates
Const sdName As String = "Sheet1"
Const sdFirst As String = "B2"
' Source Cities
Const scName As String = "Sheet1"
Const scFirst As String = "F9"
' Destination
Const dName As String = "Sheet2"
Const dFirst As String = "B2"
Const dHeader As String = "Name"
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
' Source Dates
Dim sdws As Worksheet: Set sdws = wb.Worksheets(sdName)
Dim sdrg As Range: Set sdrg = sdws.Range(sdFirst).CurrentRegion
Dim sdData As Variant: sdData = sdrg.Value
Dim sdrCount As Long: sdrCount = sdrg.Rows.Count
Dim sdcCount As Long: sdcCount = sdrg.Columns.Count
' Source Cities
Dim scws As Worksheet: Set scws = wb.Worksheets(scName)
Dim scrg As Range: Set scrg = scws.Range(scFirst).CurrentRegion
Dim scData As Variant: scData = scrg.Value
Dim schrg As Range: Set schrg = scrg.Rows(1)
Dim scrCount As Long: scrCount = scrg.Rows.Count
Dim sctCount As Long: sctCount = Application.CountA(scrg)
' Destination Array
Dim drCount As Long: drCount = sctCount + 1 ' '+ 1' for headers
Dim dcCount As Long: dcCount = 1 + sdcCount ' 1 for 'Name'
Dim dData As Variant: ReDim dData(1 To drCount, 1 To dcCount)
' Write headers to Destination Array.
Dim sdc As Long
dData(1, 1) = dHeader
For sdc = 1 To sdcCount
dData(1, sdc + 1) = sdData(1, sdc)
Next sdc
' Write 'body' to Destination Array.
Dim dr As Long: dr = 1 ' 1 for headers
Dim sccIndex As Variant
Dim scValue As Variant
Dim sdr As Long
Dim scr As Long
For sdr = 2 To sdrCount
sccIndex = Application.Match(sdData(sdr, 1), schrg, 0)
For scr = 2 To scrCount
scValue = scData(scr, sccIndex)
If Not IsError(scValue) Then
If Len(scValue) > 0 Then
dr = dr + 1
dData(dr, 1) = scValue
For sdc = 1 To sdcCount
dData(dr, sdc + 1) = sdData(sdr, sdc)
Next sdc
End If
End If
Next scr
Next sdr
' Write Destination Array to Destination Range.
Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
Dim dfcell As Range: Set dfcell = dws.Range(dFirst)
Dim drg As Range: Set drg = dfcell.Resize(drCount, dcCount)
drg.Value = dData
' Clear Destination Clear Range, the range below Destination Range.
Dim dcrg As Range
Set dcrg = drg.Resize(drg.Worksheet.Rows.Count - drg.Row - drCount + 1) _
.Offset(drCount)
dcrg.Clear ' or 'dcrg.ClearContents'
' Format e.g.:
drg.Rows(1).Font.Bold = True
dws.Range(drg.Columns(3), drg.Columns(dcCount)).Resize(drCount - 1) _
.Offset(1).NumberFormat = "dd/mm/yyyy" ' possibly "dd\/mm\/yyyy"
drg.EntireColumn.AutoFit
'wb.Save
End Sub
满足要求
Sheet2中有姓名，请填写其他栏目。
Sub FillTable2()
' Source Dates
Const sdName As String = "Sheet1"
Const sdFirst As String = "B2"
' Source Cities
Const scName As String = "Sheet1"
Const scFirst As String = "F9"
' Destination
Const dName As String = "Sheet2"
Const dFirst As String = "B2"
Dim wb As Workbook: Set wb = ThisWorkbook
' Source Dates
Dim sdws As Worksheet: Set sdws = wb.Worksheets(sdName)
Dim sdrg As Range: Set sdrg = sdws.Range(sdFirst).CurrentRegion
Dim sddrg As Range: Set sddrg = sdrg.Resize(sdrg.Rows.Count - 1).Offset(1)
Dim sdData As Variant: sdData = sddrg.Value
Dim sdrlrg As Range: Set sdrlrg = sddrg.Columns(1) ' Row Labels
' Source Cities
Dim scws As Worksheet: Set scws = wb.Worksheets(scName)
Dim scrg As Range: Set scrg = scws.Range(scFirst).CurrentRegion
Dim schRow As Long: schRow = scrg.Row ' Header Row
Dim scdrg As Range: Set scdrg = scrg.Resize(scrg.Rows.Count - 1).Offset(1)
Dim scrCount As Long: scrCount = scdrg.Rows.Count
Dim sccCount As Long: sccCount = scdrg.Columns.Count
' Destination Names
Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
Dim dfcell As Range: Set dfcell = dws.Range(dFirst)
Dim drg As Range: Set drg = dfcell.CurrentRegion.Columns(1)
Dim dnrg As Range: Set dnrg = drg.Resize(drg.Rows.Count - 1).Offset(1)
Dim dnData As Variant: dnData = dnrg.Value
' Destination Array
Dim drCount As Long: drCount = dnrg.Rows.Count
Dim dcCount As Long: dcCount = sdrg.Columns.Count
Dim dData As Variant: ReDim dData(1 To drCount, 1 To dcCount)
Dim scCell As Range
Dim dnValue As Variant
Dim scValue As Variant
Dim sdrIndex As Variant
Dim r As Long
Dim c As Long
For r = 1 To drCount
dnValue = dnData(r, 1)
If NoErrorNorBlank(dnValue) Then
Set scCell = Nothing
Set scCell = scdrg.Find(dnValue, _
scdrg.Cells(scrCount, sccCount), xlFormulas, xlWhole)
If Not scCell Is Nothing Then
scValue = scCell.EntireColumn.Rows(schRow).Value
If NoErrorNorBlank(scValue) Then
sdrIndex = Application.Match(scValue, sdrlrg, 0)
If IsNumeric(sdrIndex) Then
For c = 1 To dcCount
dData(r, c) = sdData(sdrIndex, c)
Next c
End If
End If
End If
End If
Next r
Set drg = dnrg.Offset(, 1).Resize(, dcCount)
drg.Value = dData
'wb.Save
End Sub
Function NoErrorNorBlank( _
ByVal CheckValue As Variant) _
As Boolean
If Not IsError(CheckValue) Then
If Len(CheckValue) > 0 Then
NoErrorNorBlank = True
End If
End If
End Function
我有两张表，我需要获取每个人的字段名称。为此，我需要在 sheet2 中排一个人，然后我必须在右侧的 sheet1 中获取此人分配的字段 table（对于每一行）。对于这部分，我找到并修改了这段 VBA 代码，但它并没有满足我的需要……:
Dim rgFound As Range
Dim defVal As Range
Dim currParam As Range
Dim currParamDict As Range
With Worksheets("Sheet2")
For Each defVal In .Range("B3", .Range("B" & Rows.Count).End(xlUp)).Offset(, 1)
Set currParam = defVal.Offset(, -1)
If Len(currParam.Value) > 0 Then
Set rgFound = Worksheets("Sheet1").Range("F9:I12").Find(currParam.Value)
If rgFound Is Nothing Then
Debug.Print "Name was not found."
Else
Set currParamDict = rgFound.Offset(, 0)
defVal.Value = currParamDict.Value
End If
End If
Next defVal
End With
I dont know for the range in : Set rgFound = Worksheets("Sheet1").Range("F9:I12").Find(currParam.Value)
我放了一些示例图片，以便您了解它的内容。
工作表 1：
工作表 2：
完成这一步后，我必须使用 Sheet1 的左侧 table 填写与字段对应的日期...
这一行不是标识分区，而是搜索中的名称本身。更改语句以引用第 9 行中的数据。我假设位置是固定的，如果不是那么你需要另一种方法。
Set currParamDict = rgFound.Offset(, 0)
' becomes
set currParamDict = Worksheets("sheet1").Cells(9, rgFound.Column)
填一个Table
偏离轨道
- 忽略
Sheet2中可能的旧数据并写入完整的 table。
Option Explicit
Sub FillTable()
' Source Dates
Const sdName As String = "Sheet1"
Const sdFirst As String = "B2"
' Source Cities
Const scName As String = "Sheet1"
Const scFirst As String = "F9"
' Destination
Const dName As String = "Sheet2"
Const dFirst As String = "B2"
Const dHeader As String = "Name"
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
' Source Dates
Dim sdws As Worksheet: Set sdws = wb.Worksheets(sdName)
Dim sdrg As Range: Set sdrg = sdws.Range(sdFirst).CurrentRegion
Dim sdData As Variant: sdData = sdrg.Value
Dim sdrCount As Long: sdrCount = sdrg.Rows.Count
Dim sdcCount As Long: sdcCount = sdrg.Columns.Count
' Source Cities
Dim scws As Worksheet: Set scws = wb.Worksheets(scName)
Dim scrg As Range: Set scrg = scws.Range(scFirst).CurrentRegion
Dim scData As Variant: scData = scrg.Value
Dim schrg As Range: Set schrg = scrg.Rows(1)
Dim scrCount As Long: scrCount = scrg.Rows.Count
Dim sctCount As Long: sctCount = Application.CountA(scrg)
' Destination Array
Dim drCount As Long: drCount = sctCount + 1 ' '+ 1' for headers
Dim dcCount As Long: dcCount = 1 + sdcCount ' 1 for 'Name'
Dim dData As Variant: ReDim dData(1 To drCount, 1 To dcCount)
' Write headers to Destination Array.
Dim sdc As Long
dData(1, 1) = dHeader
For sdc = 1 To sdcCount
dData(1, sdc + 1) = sdData(1, sdc)
Next sdc
' Write 'body' to Destination Array.
Dim dr As Long: dr = 1 ' 1 for headers
Dim sccIndex As Variant
Dim scValue As Variant
Dim sdr As Long
Dim scr As Long
For sdr = 2 To sdrCount
sccIndex = Application.Match(sdData(sdr, 1), schrg, 0)
For scr = 2 To scrCount
scValue = scData(scr, sccIndex)
If Not IsError(scValue) Then
If Len(scValue) > 0 Then
dr = dr + 1
dData(dr, 1) = scValue
For sdc = 1 To sdcCount
dData(dr, sdc + 1) = sdData(sdr, sdc)
Next sdc
End If
End If
Next scr
Next sdr
' Write Destination Array to Destination Range.
Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
Dim dfcell As Range: Set dfcell = dws.Range(dFirst)
Dim drg As Range: Set drg = dfcell.Resize(drCount, dcCount)
drg.Value = dData
' Clear Destination Clear Range, the range below Destination Range.
Dim dcrg As Range
Set dcrg = drg.Resize(drg.Worksheet.Rows.Count - drg.Row - drCount + 1) _
.Offset(drCount)
dcrg.Clear ' or 'dcrg.ClearContents'
' Format e.g.:
drg.Rows(1).Font.Bold = True
dws.Range(drg.Columns(3), drg.Columns(dcCount)).Resize(drCount - 1) _
.Offset(1).NumberFormat = "dd/mm/yyyy" ' possibly "dd\/mm\/yyyy"
drg.EntireColumn.AutoFit
'wb.Save
End Sub
满足要求
Sheet2中有姓名，请填写其他栏目。
Sub FillTable2()
' Source Dates
Const sdName As String = "Sheet1"
Const sdFirst As String = "B2"
' Source Cities
Const scName As String = "Sheet1"
Const scFirst As String = "F9"
' Destination
Const dName As String = "Sheet2"
Const dFirst As String = "B2"
Dim wb As Workbook: Set wb = ThisWorkbook
' Source Dates
Dim sdws As Worksheet: Set sdws = wb.Worksheets(sdName)
Dim sdrg As Range: Set sdrg = sdws.Range(sdFirst).CurrentRegion
Dim sddrg As Range: Set sddrg = sdrg.Resize(sdrg.Rows.Count - 1).Offset(1)
Dim sdData As Variant: sdData = sddrg.Value
Dim sdrlrg As Range: Set sdrlrg = sddrg.Columns(1) ' Row Labels
' Source Cities
Dim scws As Worksheet: Set scws = wb.Worksheets(scName)
Dim scrg As Range: Set scrg = scws.Range(scFirst).CurrentRegion
Dim schRow As Long: schRow = scrg.Row ' Header Row
Dim scdrg As Range: Set scdrg = scrg.Resize(scrg.Rows.Count - 1).Offset(1)
Dim scrCount As Long: scrCount = scdrg.Rows.Count
Dim sccCount As Long: sccCount = scdrg.Columns.Count
' Destination Names
Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
Dim dfcell As Range: Set dfcell = dws.Range(dFirst)
Dim drg As Range: Set drg = dfcell.CurrentRegion.Columns(1)
Dim dnrg As Range: Set dnrg = drg.Resize(drg.Rows.Count - 1).Offset(1)
Dim dnData As Variant: dnData = dnrg.Value
' Destination Array
Dim drCount As Long: drCount = dnrg.Rows.Count
Dim dcCount As Long: dcCount = sdrg.Columns.Count
Dim dData As Variant: ReDim dData(1 To drCount, 1 To dcCount)
Dim scCell As Range
Dim dnValue As Variant
Dim scValue As Variant
Dim sdrIndex As Variant
Dim r As Long
Dim c As Long
For r = 1 To drCount
dnValue = dnData(r, 1)
If NoErrorNorBlank(dnValue) Then
Set scCell = Nothing
Set scCell = scdrg.Find(dnValue, _
scdrg.Cells(scrCount, sccCount), xlFormulas, xlWhole)
If Not scCell Is Nothing Then
scValue = scCell.EntireColumn.Rows(schRow).Value
If NoErrorNorBlank(scValue) Then
sdrIndex = Application.Match(scValue, sdrlrg, 0)
If IsNumeric(sdrIndex) Then
For c = 1 To dcCount
dData(r, c) = sdData(sdrIndex, c)
Next c
End If
End If
End If
End If
Next r
Set drg = dnrg.Offset(, 1).Resize(, dcCount)
drg.Value = dData
'wb.Save
End Sub
Function NoErrorNorBlank( _
ByVal CheckValue As Variant) _
As Boolean
If Not IsError(CheckValue) Then
If Len(CheckValue) > 0 Then
NoErrorNorBlank = True
End If
End If
End Function