动态字段填充VBA

Question

我写了一个简化电子表格的脚本，但我需要动态填充字段的帮助。电子表格的当前格式具有不一致的间距，因此难以放在一起，并且如果填充的语句仅填充文档的子部分。

我已附加文档外观的。

我想要做的是根据右侧突出显示的字段在左侧填充突出显示的字段。例如（当字段“F3”填入时 - 如果“2012”和“092000”，则从单元格“A4”到“A11”的单元格“F2”中将“BBFY”填充为“2012”）在下一个BOC号码处停止。然后如果有新的数据为BOC名称2013 092300，请根据该信息填写相应的信息

我只是在尝试识别正在进行的许多更改的正确调用时遇到问题很难告诉代码根据新参数改变数值，因为你可以看到F中突出显示的值发生变化，从而改变了下面的相关信息，我已经阻止了我试图启动这部分代码的地方

我到目前为止的代码让我看到下面看到的布局。另外我正在尝试做一个新的工作表基于每个部分，但我会尽力解决这个问题。

Sub SOFCMacro() 

'Begins Macro Optimizations 
    Application.ScreenUpdating = False 
    Application.EnableEvents = False 
    Application.Calculation = xlCalculationManual 
    Application.DisplayAlerts = False 

'Declarations 
    Dim Firstrow As Long 
    Dim Lastrow As Long 
    Dim Lrow As Long 
Dim rng As Range 

'Renames Sheet1 and Make It an Object 
    Set Main = ActiveSheet 
    Main.Name = "BAR" 

'Add and Name Worksheets 
    Set WS1 = Sheets.Add 
    WS1.Name = "SOFC" 

'Clear Formatting 
    Sheets("BAR").Activate 
    With ActiveSheet 
    .Cells.ClearFormats 
    End With 

***'Comma Diliminate Funding Information 
    Sheets("Bar").Activate 
    With ActiveSheet 
    Set rng = .Range(rng, .Cells(.Rows.Count, rng.Column).End(xlUp)) 
    For i = Last To 1 Step -1 
     If Not IsError(.vaule) Then 
      ElseIf (cells(i, "F").value = "092000:" and "Salaries:" Then cells(Cells, i, "A").value = (Cells(i, "F").Value) Like "20*" 
      ElseIf .value = "092300:" and "Defender:" Then cells(Cells, i, "A").value = (Cells(i, "F").Value) Like "20*" 
      ElseIf .value = "51140X:" and "Judiciary:" Then cells(Cells, i, "A").value = (Cells(i, "F").Value) Like "20*" 
      ElseIf .value = "51140E:" and "Electronic:" Then cells(Cells, i, "A").value = (Cells(i, "F").Value) Like "20*" 
    End if 
End With*** 

'Copies Columns from Budget Availability Reports to SOFC Worksheet 
    Sheets("BAR").Columns(1).Copy Destination:=Sheets("SOFC").Columns(4) 
    Sheets("BAR").Columns(2).Copy Destination:=Sheets("SOFC").Columns(5) 
    Sheets("BAR").Columns(3).Copy Destination:=Sheets("SOFC").Columns(6) 
    Sheets("BAR").Columns(4).Copy Destination:=Sheets("SOFC").Columns(7) 

'Deletes "Main Worksheet" 
    Sheets("BAR").Delete 

'Inserts Header Row 
    Sheets("SOFC").Range("A2").EntireRow.Insert 

'Add Headers to Sheet 
    Sheets("SOFC").Range("A1").Value = "BBFY" 
    Sheets("SOFC").Range("B1").Value = "EBFY" 
    Sheets("SOFC").Range("C1").Value = "FUND" 
    Sheets("SOFC").Range("D1").Value = "BUDGET ORG" 
    Sheets("SOFC").Range("E1").Value = "BOC" 
    Sheets("SOFC").Range("F1").Value = "BOC Name" 
    Sheets("SOFC").Range("G1").Value = "ALLOTMENT" 

'Deletes Unneeded Rows 
    Sheets("SOFC").Activate 
    With ActiveSheet 
    Firstrow = .UsedRange.Cells(1).Row 
    Lastrow = .UsedRange.Rows(.UsedRange.Rows.Count).Row 
    For Lrow = Lastrow To Firstrow Step -1 
     With .Cells(Lrow, "D") 
      If Not IsError(.Value) Then 
       ElseIf .Value = "Activity Type:" Then .EntireRow.Delete 
       ElseIf .Value = "Activity:" Then .EntireRow.Delete 
       ElseIf .Value = "AO Division:" Then .EntireRow.Delete 
      End If 
     End With 
    Next Lrow 
End With 

'Deletes Rows Based On Criteria 
    Last = Cells(Rows.Count, "D").End(xlUp).Row 
    For i = Last To 1 Step -1 
     If (Cells(i, "D").Value) = "Fund:" Then 
     'Cells(i, "A").EntireRow.ClearContents ' USE THIS TO CLEAR CONTENTS BUT NOT DELETE ROW 

     ElseIf (Cells(i, "D").Value) = "Activity Type:" Then 
      Cells(i, "A").EntireRow.Delete 
     ElseIf (Cells(i, "D").Value) = "Activity:" Then 
      Cells(i, "A").EntireRow.Delete 
     ElseIf (Cells(i, "D").Value) = "AO Division:" Then 
      Cells(i, "A").EntireRow.Delete 
     ElseIf (Cells(i, "D").Value) = " Org Code" Then 
      Cells(i, "A").EntireRow.Delete 
     ElseIf (Cells(i, "F").Value) = "Org Code Subtotal:" Then 
      Cells(i, "A").EntireRow.Delete 
     ElseIf (Cells(i, "F").Value) = "AO Division Subtotal:" Then 
      Cells(i, "A").EntireRow.Delete 
     ElseIf (Cells(i, "F").Value) = "Activity Subtotal:" Then 
      Cells(i, "A").EntireRow.Delete 
     ElseIf (Cells(i, "F").Value) = "Activity Type Subtotal:" Then 
      Cells(i, "A").EntireRow.Delete 
     ElseIf (Cells(i, "F").Value) = "Fund Subtotal:" Then 
      Cells(i, "A").EntireRow.Delete 
'Change Values for Courts in Current Wave 
     ElseIf (Cells(i, "F").Value) = "ARW - Arkansas Western" Then 
      Cells(i, "A").EntireRow.Delete 
     ElseIf (Cells(i, "F").Value) = "CAN - California Northern" Then 
      Cells(i, "A").EntireRow.Delete 
     ElseIf (Cells(i, "F").Value) = "GAS - Georgia Southern" Then 
      Cells(i, "A").EntireRow.Delete 
     ElseIf (Cells(i, "F").Value) = "MDX - Maryland" Then 
      Cells(i, "A").EntireRow.Delete 
     ElseIf (Cells(i, "F").Value) = "NDX - North Dakota" Then 
      Cells(i, "A").EntireRow.Delete 
     ElseIf (Cells(i, "F").Value) = "NYE - New York Eastern" Then 
      Cells(i, "A").EntireRow.Delete 
     ElseIf (Cells(i, "F").Value) = "ORX - Oregon" Then 
      Cells(i, "A").EntireRow.Delete 
     ElseIf (Cells(i, "F").Value) = "SDX - South Dakota" Then 
      Cells(i, "A").EntireRow.Delete 
'Change Values for Courts in Current Wave 
     ElseIf (Cells(i, "F").Value) = "" Then 
      Cells(i, "A").EntireRow.Delete 
    Else 
    End If 
Next i 

'Gets BBFY and Fund and Place Values in Correct Columns 
'Last = Cells(Rows.Count, "D").End(xlUp).Row 
    For i = Last To 1 Step -1 
    If (Cells(i, "D").Value) = "Fund:" Then 
     ElseIf (Cells(i, "F").Value) Like "20*" Then 
     YearYo = Left(Cells(i, "20*"), 4) 
     If Date Like "20*" Then 
     Cells(i, "A").Value = Date 
     End If 
    Else 

    End If 
Next i 

'Gets Leading 0 for Fund Code 
    Columns("C:C").Select 
    Selection.NumberFormat = "000000" 


End Sub 

Answer 1

一个建议，如果你的电子表格在BOC专栏中是一致的，那么也许这是最好的开始。

Dim i as Integer 
Dim j as Integer 
Dim LR as Long 
LR = Cells(Sheets("NAME").Columns(6).Rows.Count, 1).End(xlUp).Row 

For j = 1 to LR 
For i = 1 to 3 
If Cells(j,i)/Value="" Then 
     Cells(j,i).Formula= 'come up with reference for the BOC Name 
    Else: 
    End If 

Next i 
Next j 

这不是完美的，也许可以做一个更好的为每一个（我不是很好用的），但它可能是至少一个开始。此选项不会找到动态范围来填充空白（例如，动态定义大块黄色方块并粘贴到它们中）。它只是循环遍历前3行中的所有单元格，直到最后一行的结尾（使用列F（Columns（6）），因为它似乎是您唯一完全填充的列）。

如果您想更具体到什么进入每个单元：

Dim i as Integer 
Dim LR as Long 
LR = Cells(Sheets("NAME").Columns(6).Rows.Count, 1).End(xlUp).Row 

For i = 1 to LR 

If Cells(i,1)/Value="" Then 
     Cells(i,1).Formula= "=Left(REF,4)'come up with reference for the BOC Name 
     Cells(i,2).Formula= "=Left(Right(REF,6),11) 
     Cells(i,3).Formula= "=Right(REF,3) 
    Else: 
    End If 

Next i