我的一份財務報告有以下代碼，我正在努力更新代碼以使其更加自動化。該代碼創建存盤在 wb1.Sheets(MHP60) 選項卡中的列標題字串。每個列標題都是 wb2 中的一個新選項卡。我不知道如何設定代碼以讀取字串 MHP60，然后如果找到該字串，則需要將值復制到 wb2 中的該表，然后繼續下一個。我從硬編碼開始，但如果添加了額外的列，它也無濟于事。我檢查了其他一些帖子，但我不知道如何開始。我覺得我錯過了一種更簡單的方法。
因此代碼需要： 1/將列標題放入字串/陣列 2/查看字串/陣列并在 wb1 中找到該列 3/然后將特定范圍復制到 wb2（名稱基于列標題/字串值） 4 /轉到下一個值
任何幫助或方向將不勝感激。
Sub Prepare_CYTD_Report()
Dim wb1 As Workbook, wb2 As Workbook
Dim MHP60, MHP61, MHP62 As String
Dim i, j, lCol60, lCol61, lCol62 As Long 'last columns in MHP worksheets
Dim my_Filename
Application.ScreenUpdating = False
Set wb1 = ActiveWorkbook 'Trial Balance to Financial Statements
'lastCol61 = wb1.Sheets("MHP61").Cells(5, Columns.Count).End(xlToLeft).Column 'Find the last non-blank cell in header row
'lastCol62 = wb1.Sheets("MHP62").Cells(5, Columns.Count).End(xlToLeft).Column 'Find the last non-blank cell in header row
'*****************************Create Header Array for MHP60 tab
lastCol60 = wb1.Sheets("MHP60").Cells(5, Columns.Count).End(xlToLeft).Column 'Find the last non-blank cell in header row
ReDim MHP60(1 To lCol60)
For i = 3 To lCol60 Step 1
If (Not IsEmpty(Cells(4, i).Value)) Then ' checks to make sure the value isn't empty
j = j 1
MHP60(j) = Cells(4, i).Value
End If
Next i
ReDim Preserve MHP60(1 To j)
For j = LBound(MHP60) To UBound(MHP60) ' loop through the previous array
MHP60(j) = Replace(MHP60(j), " ", "")
MHP60(j) = Replace(MHP60(j), ",", "")
Next j
'*****************************Open CYTD/FYTD files
my_Filename = Application.GetOpenFilename(FileFilter:="Excel Files,*.xl*;*.xm*")
If my_Filename = False Then
Exit Sub
End If
Set wb2 = Workbooks.Open(my_Filename) 'Monthly Report file
'*****************************Code to copy values to CYTD/FYTD Files
'MHP60 - column C - 1009 SNP-F
wb2.Sheets("1009 SNP-F").Range("A12:A26").Value = wb1.Sheets("MHP60").Range("C12:C26").Value
wb2.Sheets("1009 SNP-F").Range("A32:A38").Value = wb1.Sheets("MHP60").Range("C32:C38").Value
wb2.Sheets("1009 SNP-F").Range("A42:A58").Value = wb1.Sheets("MHP60").Range("C42:C58").Value
wb2.Sheets("1009 SNP-F").Range("A62:A70").Value = wb1.Sheets("MHP60").Range("C62:C70").Value
wb2.Sheets("1009 SNP-F").Range("A73:A76").Value = wb1.Sheets("MHP60").Range("C73:C76").Value
wb2.Sheets("1009 SNP-F").Range("A83:A90").Value = wb1.Sheets("MHP60").Range("C83:C90").Value
'MHP60 - column I - 1014 MA-PD-F
wb2.Sheets("1014 MA-PD-F").Range("A12:A26").Value = wb1.Sheets("MHP60").Range("D12:D26").Value
wb2.Sheets("1014 MA-PD-F").Range("A32:A38").Value = wb1.Sheets("MHP60").Range("D32:D38").Value
wb2.Sheets("1014 MA-PD-F").Range("A42:A58").Value = wb1.Sheets("MHP60").Range("D42:D58").Value
wb2.Sheets("1014 MA-PD-F").Range("A62:A70").Value = wb1.Sheets("MHP60").Range("D62:D70").Value
wb2.Sheets("1014 MA-PD-F").Range("A73:A76").Value = wb1.Sheets("MHP60").Range("D73:D76").Value
wb2.Sheets("1014 MA-PD-F").Range("A83:A90").Value = wb1.Sheets("MHP60").Range("D83:D90").Value
'MHP60 - column I - 1061 ABAD-F
wb2.Sheets("1061 ABAD-F").Range("A12:A26").Value = wb1.Sheets("MHP60").Range("E12:E26").Value
wb2.Sheets("1061 ABAD-F").Range("A32:A38").Value = wb1.Sheets("MHP60").Range("E32:E38").Value
wb2.Sheets("1061 ABAD-F").Range("A42:A58").Value = wb1.Sheets("MHP60").Range("E42:E58").Value
wb2.Sheets("1061 ABAD-F").Range("A62:A70").Value = wb1.Sheets("MHP60").Range("E62:E70").Value
wb2.Sheets("1061 ABAD-F").Range("A73:A76").Value = wb1.Sheets("MHP60").Range("E73:E76").Value
wb2.Sheets("1061 ABAD-F").Range("A83:A90").Value = wb1.Sheets("MHP60").Range("E83:E90").Value
Application.ScreenUpdating = True
End Sub
uj5u.com熱心網友回復：
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$1)")) = "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 行的實際單元格值是實際選項卡名稱的“原樣”值
- 這些單元格值是手動輸入的，即不是公式驅動的
轉載請註明出處，本文鏈接：https://www.uj5u.com/qiye/472664.html