根据存储在字符串中的值将数据复制到另一个电子表格
Copy data to another spreadsheet based off value stored in string
我的一份财务报告有以下代码，我正在努力更新代码以使其更加自动化。该代码创建存储在多个工作表中的 header 列的字符串。每列 header 都是 wb2 中的一个新选项卡。我不知道如何将公式复制到新的地址范围。它需要将值复制到 wb2 中的 Sheet，然后转到下一个。
所以代码需要：
1/将列 headers 放入 string/array [Works]
2/查看 string/array 并在 wb1 [Works] 中找到该列
3/然后将特定范围复制到 wb2（名称基于列 header/string 值）[Works]
4/将公式复制到 G 列，基于类似于它对 A 列地址所做的行 - 例如，如果范围是 G9，则需要复制公式 H9-A9 等
5/转到下一个值
如有任何帮助或指导，我们将不胜感激。
Sub Prepare_CYTD_Report()
Dim addresses() As String
Dim addresses2() As String
Dim wb1 As Workbook, wb2 As Workbook
Dim my_Filename
'Declare variables for MHP60
Dim i As Long, lastcol As Long
Dim tabNames As Range, cell As Range, tabName As String
'Declare variables for MHP61
Dim i2 As Long, lastCol2 As Long
Dim tabNames2 As Range, cell2 As Range, tabName2 As String
'Declare variables for MHP62
Dim i3 As Long, lastCol3 As Long
Dim tabNames3 As Range, cell3 As Range, tabName3 As String
addresses = Strings.Split("A9,A12:A26,A32:A38,A42:A58,A62:A70,A73:A76,A83:A90", ",") 'Trial Balance string values
addresses2 = Strings.Split("G9,G12:G26,G32:G38,G42:G58,G62:G70,G73:G76,G83:G90", ",") 'Prior Month string values
Set wb1 = ActiveWorkbook 'Trial Balance to Financial Statements Workbook
'*****************************Load Column Header Strings
lastcol = wb1.Sheets("MHP60").Cells(5, Columns.Count).End(xlToLeft).Column
On Error Resume Next
Set tabNames = wb1.Sheets("MHP60").Cells(4, 3).Resize(1, lastcol - 2).SpecialCells(xlCellTypeConstants)
'actual non-formula text values on row 4 from column C up to column lastCol'
On Error GoTo 0
If Err.Number <> 0 Then
MsgBox "No headers were found on row 4 of MHP60", vbCritical
Exit Sub
End If
lastCol2 = wb1.Sheets("MHP61").Cells(5, Columns.Count).End(xlToLeft).Column
On Error Resume Next
Set tabNames2 = wb1.Sheets("MHP61").Cells(4, 3).Resize(1, lastcol - 2).SpecialCells(xlCellTypeConstants)
'actual non-formula text values on row 4 from column C up to column lastCol'
On Error GoTo 0
If Err.Number <> 0 Then
MsgBox "No headers were found on row 4 of MHP61", vbCritical
Exit Sub
End If
lastCol3 = wb1.Sheets("MHP62").Cells(5, Columns.Count).End(xlToLeft).Column
On Error Resume Next
Set tabNames3 = wb1.Sheets("MHP62").Cells(4, 3).Resize(1, lastcol - 2).SpecialCells(xlCellTypeConstants)
'actual non-formula text values on row 4 from column C up to column lastCol'
On Error GoTo 0
If Err.Number <> 0 Then
MsgBox "No headers were found on row 4 of MHP62", vbCritical
Exit Sub
End If
'*****************************Open CYTD/FYTD files
my_Filename = Application.GetOpenFilename(fileFilter:="Excel Files,*.xl*;*.xm*", Title:="Select File to create Reports")
If my_Filename = False Then
Exit Sub
End If
Application.ScreenUpdating = False
Set wb2 = Workbooks.Open(my_Filename)
'*****************************Copy values to Financial statements workbook
For Each cell In tabNames
tabName = Strings.Trim(cell.Value2)
'dedicated variable in case of requirement for further parsing (space/comma elimination?)'
If CStr(wb1.Sheets("MHP60").Evaluate("ISREF('[" & wb2.Name & "]" & tabName & "'!$A)")) = "True" Then
'If wb2 has a tab named for the value in tabName
For i = 0 To UBound(addresses)
wb2.Sheets(tabName).Range(addresses(i)).Value2 = wb1.Sheets("MHP60").Range(addresses(i)).Offset(0, cell.Column - 1).Value2
'wb2.Sheets(tabName).Range(addresses2(i)).Value2 =
'Debug.Print "data for " & wb2.Sheets(tabName).Range(addresses(i)).Address(, , , True) & " copied from " & wb1.Sheets("MHP60").Range(addresses(i)).Offset(0, cell.Column - 1).Address(, , , True)
Next i
Else
Debug.Print "A tab " & tabName & " was not found in " & wb2.Name
End If
Next cell
For Each cell In tabNames2
tabName2 = Strings.Trim(cell.Value2)
'dedicated variable in case of requirement for further parsing (space/comma elimination?)'
If CStr(wb1.Sheets("MHP61").Evaluate("ISREF('[" & wb2.Name & "]" & tabName2 & "'!$A)")) = "True" Then
'If wb2 has a tab named for the value in tabName
For i = 0 To UBound(addresses)
wb2.Sheets(tabName2).Range(addresses(i)).Value2 = wb1.Sheets("MHP61").Range(addresses(i)).Offset(0, cell.Column - 1).Value2
'Debug.Print "data for " & wb2.Sheets(tabName2).Range(addresses(i)).Address(, , , True) & " copied from " & wb1.Sheets("MHP61").Range(addresses(i)).Offset(0, cell.Column - 1).Address(, , , True)
Next i
Else
Debug.Print "A tab " & tabName2 & " was not found in " & wb2.Name
End If
Next cell
For Each cell In tabNames3
tabName3 = Strings.Trim(cell.Value2)
'dedicated variable in case of requirement for further parsing (space/comma elimination?)'
If CStr(wb1.Sheets("MHP62").Evaluate("ISREF('[" & wb2.Name & "]" & tabName3 & "'!$A)")) = "True" Then
'If wb2 has a tab named for the value in tabName
For i = 0 To UBound(addresses)
wb2.Sheets(tabName3).Range(addresses(i)).Value2 = wb1.Sheets("MHP62").Range(addresses(i)).Offset(0, cell.Column - 1).Value2
'Debug.Print "data for " & wb2.Sheets(tabName2).Range(addresses(i)).Address(, , , True) & " copied from " & wb1.Sheets("MHP62").Range(addresses(i)).Offset(0, cell.Column - 1).Address(, , , True)
Next i
Else
Debug.Print "A tab " & tabName3 & " was not found in " & wb2.Name
End If
Next cell
Application.ScreenUpdating = True
结束子
Sub Prepare_CYTD_Report()
Dim addresses() As String
Dim wb1 As Workbook, wb2 As Workbook
Dim i As Long, lastCol As Long, my_FileName
Dim tabNames As Range, cell As Range, tabName As String
addresses = Strings.Split("A12:A26,A32:A38,A42:A58,A62:A70,A73:A76,A83:A90", ",")
Set wb1 = ActiveWorkbook 'Trial Balance to Financial Statements
lastCol = wb1.Sheets("MHP60").Cells(5, Columns.Count).End(xlToLeft).Column
On Error Resume Next
Set tabNames = wb1.Sheets("MHP60").Cells(4, 3).Resize(1, lastCol - 2).SpecialCells(xlCellTypeConstants)
'actual non-formula text values on row 4 from column C up to column lastCol'
On Error GoTo 0
If Err.Number <> 0 Then
MsgBox "No headers were found on row 4 of MHP60", vbCritical
Exit Sub
End If
'*****************************Open CYTD/FYTD files
my_FileName = Application.GetOpenFilename(FileFilter:="Excel Files,*.xl*;*.xm*")
If my_FileName = False Then
Exit Sub
End If
Application.ScreenUpdating = False
Set wb2 = Workbooks.Open(my_FileName)
For Each cell In tabNames
tabName = Strings.Trim(cell.Value2)
'dedicated variable in case of requirement for further parsing (space/comma elimination?)'
If CStr(wb2.Worksheets(1).Evaluate("ISREF('" & tabName & "'!$A)")) = "True" Then
'If wb2 has a tab named for the value in tabName
For i = 0 To UBound(addresses)
wb2.Sheets(tabName).Range(addresses(i)).Value2 = wb1.Sheets("MHP60").Range(addresses(i)).Offset(0, cell.Column - 1).Value2
'Debug.Print "data for " & wb2.Sheets(tabName).Range(addresses(i)).Address(, , , True) & " copied from " & wb1.Sheets("MHP60").Range(addresses(i)).Offset(0, cell.Column - 1).Address(, , , True)
Next i
Else
Debug.Print "A tab " & tabName & " was not found in " & wb2.Name
End If
Next cell
Application.ScreenUpdating = True
End Sub
鉴于我在评论中所做的观察，上面提供的代码假设
- MHP60 第 4 行的实际单元格值是 'as is'
实际标签名称
- 这些单元格值是手动输入的，即不是 formula-driven
我的一份财务报告有以下代码，我正在努力更新代码以使其更加自动化。该代码创建存储在多个工作表中的 header 列的字符串。每列 header 都是 wb2 中的一个新选项卡。我不知道如何将公式复制到新的地址范围。它需要将值复制到 wb2 中的 Sheet，然后转到下一个。
所以代码需要： 1/将列 headers 放入 string/array [Works] 2/查看 string/array 并在 wb1 [Works] 中找到该列 3/然后将特定范围复制到 wb2（名称基于列 header/string 值）[Works] 4/将公式复制到 G 列，基于类似于它对 A 列地址所做的行 - 例如，如果范围是 G9，则需要复制公式 H9-A9 等 5/转到下一个值
如有任何帮助或指导，我们将不胜感激。
Sub Prepare_CYTD_Report()
Dim addresses() As String
Dim addresses2() As String
Dim wb1 As Workbook, wb2 As Workbook
Dim my_Filename
'Declare variables for MHP60
Dim i As Long, lastcol As Long
Dim tabNames As Range, cell As Range, tabName As String
'Declare variables for MHP61
Dim i2 As Long, lastCol2 As Long
Dim tabNames2 As Range, cell2 As Range, tabName2 As String
'Declare variables for MHP62
Dim i3 As Long, lastCol3 As Long
Dim tabNames3 As Range, cell3 As Range, tabName3 As String
addresses = Strings.Split("A9,A12:A26,A32:A38,A42:A58,A62:A70,A73:A76,A83:A90", ",") 'Trial Balance string values
addresses2 = Strings.Split("G9,G12:G26,G32:G38,G42:G58,G62:G70,G73:G76,G83:G90", ",") 'Prior Month string values
Set wb1 = ActiveWorkbook 'Trial Balance to Financial Statements Workbook
'*****************************Load Column Header Strings
lastcol = wb1.Sheets("MHP60").Cells(5, Columns.Count).End(xlToLeft).Column
On Error Resume Next
Set tabNames = wb1.Sheets("MHP60").Cells(4, 3).Resize(1, lastcol - 2).SpecialCells(xlCellTypeConstants)
'actual non-formula text values on row 4 from column C up to column lastCol'
On Error GoTo 0
If Err.Number <> 0 Then
MsgBox "No headers were found on row 4 of MHP60", vbCritical
Exit Sub
End If
lastCol2 = wb1.Sheets("MHP61").Cells(5, Columns.Count).End(xlToLeft).Column
On Error Resume Next
Set tabNames2 = wb1.Sheets("MHP61").Cells(4, 3).Resize(1, lastcol - 2).SpecialCells(xlCellTypeConstants)
'actual non-formula text values on row 4 from column C up to column lastCol'
On Error GoTo 0
If Err.Number <> 0 Then
MsgBox "No headers were found on row 4 of MHP61", vbCritical
Exit Sub
End If
lastCol3 = wb1.Sheets("MHP62").Cells(5, Columns.Count).End(xlToLeft).Column
On Error Resume Next
Set tabNames3 = wb1.Sheets("MHP62").Cells(4, 3).Resize(1, lastcol - 2).SpecialCells(xlCellTypeConstants)
'actual non-formula text values on row 4 from column C up to column lastCol'
On Error GoTo 0
If Err.Number <> 0 Then
MsgBox "No headers were found on row 4 of MHP62", vbCritical
Exit Sub
End If
'*****************************Open CYTD/FYTD files
my_Filename = Application.GetOpenFilename(fileFilter:="Excel Files,*.xl*;*.xm*", Title:="Select File to create Reports")
If my_Filename = False Then
Exit Sub
End If
Application.ScreenUpdating = False
Set wb2 = Workbooks.Open(my_Filename)
'*****************************Copy values to Financial statements workbook
For Each cell In tabNames
tabName = Strings.Trim(cell.Value2)
'dedicated variable in case of requirement for further parsing (space/comma elimination?)'
If CStr(wb1.Sheets("MHP60").Evaluate("ISREF('[" & wb2.Name & "]" & tabName & "'!$A)")) = "True" Then
'If wb2 has a tab named for the value in tabName
For i = 0 To UBound(addresses)
wb2.Sheets(tabName).Range(addresses(i)).Value2 = wb1.Sheets("MHP60").Range(addresses(i)).Offset(0, cell.Column - 1).Value2
'wb2.Sheets(tabName).Range(addresses2(i)).Value2 =
'Debug.Print "data for " & wb2.Sheets(tabName).Range(addresses(i)).Address(, , , True) & " copied from " & wb1.Sheets("MHP60").Range(addresses(i)).Offset(0, cell.Column - 1).Address(, , , True)
Next i
Else
Debug.Print "A tab " & tabName & " was not found in " & wb2.Name
End If
Next cell
For Each cell In tabNames2
tabName2 = Strings.Trim(cell.Value2)
'dedicated variable in case of requirement for further parsing (space/comma elimination?)'
If CStr(wb1.Sheets("MHP61").Evaluate("ISREF('[" & wb2.Name & "]" & tabName2 & "'!$A)")) = "True" Then
'If wb2 has a tab named for the value in tabName
For i = 0 To UBound(addresses)
wb2.Sheets(tabName2).Range(addresses(i)).Value2 = wb1.Sheets("MHP61").Range(addresses(i)).Offset(0, cell.Column - 1).Value2
'Debug.Print "data for " & wb2.Sheets(tabName2).Range(addresses(i)).Address(, , , True) & " copied from " & wb1.Sheets("MHP61").Range(addresses(i)).Offset(0, cell.Column - 1).Address(, , , True)
Next i
Else
Debug.Print "A tab " & tabName2 & " was not found in " & wb2.Name
End If
Next cell
For Each cell In tabNames3
tabName3 = Strings.Trim(cell.Value2)
'dedicated variable in case of requirement for further parsing (space/comma elimination?)'
If CStr(wb1.Sheets("MHP62").Evaluate("ISREF('[" & wb2.Name & "]" & tabName3 & "'!$A)")) = "True" Then
'If wb2 has a tab named for the value in tabName
For i = 0 To UBound(addresses)
wb2.Sheets(tabName3).Range(addresses(i)).Value2 = wb1.Sheets("MHP62").Range(addresses(i)).Offset(0, cell.Column - 1).Value2
'Debug.Print "data for " & wb2.Sheets(tabName2).Range(addresses(i)).Address(, , , True) & " copied from " & wb1.Sheets("MHP62").Range(addresses(i)).Offset(0, cell.Column - 1).Address(, , , True)
Next i
Else
Debug.Print "A tab " & tabName3 & " was not found in " & wb2.Name
End If
Next cell
Application.ScreenUpdating = True
结束子
Sub Prepare_CYTD_Report()
Dim addresses() As String
Dim wb1 As Workbook, wb2 As Workbook
Dim i As Long, lastCol As Long, my_FileName
Dim tabNames As Range, cell As Range, tabName As String
addresses = Strings.Split("A12:A26,A32:A38,A42:A58,A62:A70,A73:A76,A83:A90", ",")
Set wb1 = ActiveWorkbook 'Trial Balance to Financial Statements
lastCol = wb1.Sheets("MHP60").Cells(5, Columns.Count).End(xlToLeft).Column
On Error Resume Next
Set tabNames = wb1.Sheets("MHP60").Cells(4, 3).Resize(1, lastCol - 2).SpecialCells(xlCellTypeConstants)
'actual non-formula text values on row 4 from column C up to column lastCol'
On Error GoTo 0
If Err.Number <> 0 Then
MsgBox "No headers were found on row 4 of MHP60", vbCritical
Exit Sub
End If
'*****************************Open CYTD/FYTD files
my_FileName = Application.GetOpenFilename(FileFilter:="Excel Files,*.xl*;*.xm*")
If my_FileName = False Then
Exit Sub
End If
Application.ScreenUpdating = False
Set wb2 = Workbooks.Open(my_FileName)
For Each cell In tabNames
tabName = Strings.Trim(cell.Value2)
'dedicated variable in case of requirement for further parsing (space/comma elimination?)'
If CStr(wb2.Worksheets(1).Evaluate("ISREF('" & tabName & "'!$A)")) = "True" Then
'If wb2 has a tab named for the value in tabName
For i = 0 To UBound(addresses)
wb2.Sheets(tabName).Range(addresses(i)).Value2 = wb1.Sheets("MHP60").Range(addresses(i)).Offset(0, cell.Column - 1).Value2
'Debug.Print "data for " & wb2.Sheets(tabName).Range(addresses(i)).Address(, , , True) & " copied from " & wb1.Sheets("MHP60").Range(addresses(i)).Offset(0, cell.Column - 1).Address(, , , True)
Next i
Else
Debug.Print "A tab " & tabName & " was not found in " & wb2.Name
End If
Next cell
Application.ScreenUpdating = True
End Sub
鉴于我在评论中所做的观察，上面提供的代码假设
- MHP60 第 4 行的实际单元格值是 'as is' 实际标签名称
- 这些单元格值是手动输入的，即不是 formula-driven