0

我有一个小问题。我从事产品开发工作，每年管理 100 多个项目，给定项目的运行时间是流动的，有些需要比计划完成的时间更长，而另一些则更快。对于每个项目，时间/成本工作簿都会设置计划成本/时间，然后在项目完成后估算实际成本/时间。到目前为止，每个表格都是手动创建、填写并保存到一个文件夹中的，这些文件的名称从未相同，并且最终以不同的标题格式结束。这使得审查项目的年平均成本/运行时间变得非常困难。

这个想法是使时间/成本工作簿的创建更简单。

工作流程：

  1. 打开工作簿“项目”
  2. 在 A 列输入项目编号：xxx-yyyy-zz（xxx = 项目编号 | yyyy = 年份 | zz = 项目类型）
  3. 在 B 列中输入项目名称
  4. 选择带有项目点击按钮“Create_Open”的行
  5. 使用模板创建新工作簿
  6. 项目编号 和项目名称被复制到模板
  7. 工作簿以文件名保存（项目编号“_”项目名称“.xml”）

那部分很简单，代码如下，它看起来不是很好，但它完成了工作。

Function FileExists(FullFileName As String) As Boolean
     'returns TRUE if the file exists
     FileExists = Len(Dir(FullFileName)) > 0
End Function



Sub Create_Workbook()

Dim selRow As Integer
Dim file_path As String
Dim file_extension As String

file_path = "...dir"                                    ' Speicherpfad festlegen
file_extension = ".xls"                                 ' Speichermedium festlegen

selRow = ActiveCell.Row 'aktive Zeile finden
    If Range("A" & selRow) = "" Then   ' prüfen ob Zeile ein Projekt enthält
        MsgBox ("Bitte eine ausgefullte Zeile auswählen")
        End
    End If

project_nr = Mid(Range("A" & selRow), 1, 11) ' zuweisen Projekt-Nr.
project_be = Mid(Range("B" & selRow), 1, 100) ' zuweisen Projekt Bezeichnung

'If Workbook Exists Open if not Create and write to Workbook
If Not FileExists(file_path & project_nr & "_" & project_be & file_extension) Then
   'Workbook null setzen und Template laden
    Set new_workbook = Nothing 'null setzen
    Set new_workbook = Workbooks.Add(Template:="dir") 'Postfach laufwerk einstellen

    'Projekt-Nr. und Projektbezeichnung in Controllingblatt speichern
    Range("C1") = project_be 'Projektbezeichnung setzen
    Range("C2") = project_nr 'Projektnummer setzen
    Range("C3") = Format(Date, "mm-dd-yyyy") 'Heutiges Datum setzen

    'Workbook speichern "Projekt-Nr._Projektbezeichnung"
    new_workbook.SaveAs Filename:=file_path & project_nr & "_" & project_be & file_extension

Else
    Workbooks.Open file_path & project_nr & "_" & project_be & file_extension
End If

End Sub

现在是我有解决所有问题的母亲的部分。在 A 列中搜索一年，一旦找到来自给定年份的项目，就会打开相应的工作簿。一系列单元格从打开的工作簿复制到项目列表工作簿中的新工作表。单元格的范围被粘贴到新的工作表中，该工作表给出了搜索年份的名称。搜索循环遍历 A 列的所有行，直到它到达一个空行。

工作流程：

  1. Buttonclick 打开用户窗口“输入年份”
  2. 在没有年份输入的情况下单击确定按钮返回错误
  3. 输入年份 点击 OK 按钮
  4. 创建具有输入年份标题的新工作表
  5. 在 A 列中搜索年份。
  6. 一旦从打开项目工作簿的对应年份找到项目
  7. 从工作簿复制一系列单元格
  8. 将单元格范围粘贴到步骤 4 中工作表中的项目列表工作簿
  9. 关闭在步骤 6 中打开的工作簿
  10. 循环 5-9 直到空单元格

到目前为止，我所拥有的并不多（代码如下），我遇到了坚固的墙壁。我想知道是否有人可以帮助我，或者我的逻辑是否完全有缺陷，我应该从头开始并以不同的方式构建系统。

Private Sub cmdOK_Click()
    If Len(Me.TextBox1 & "") = 0 Then   ' prüfen ob Zeile ein Projekt enthält
        MsgBox ("Bitte Jahr eingeben")
    Else
        'Loop through cells on a sheet to find strFind1
    End If
End Sub

任何帮助深表感谢。

4

2 回答 2

0

希望这可以帮助。我尝试了一个测试，我想我得到了它非常接近你的问题。我有一个 projectList 工作簿，在第一张表上我在 A 列中有以下值

  • 111-2010-222
  • 222-2010-333
  • 333-2010-144
  • 444-2011-111
  • 555-2011-222

然后我有一个名为的按钮sumProjects，在单元格中D2我有我想要总计的年份。对于上面的每个项目名称，我创建了一个名称相同的电子表格，并在这些电子表格中将一些数据放入 column D。然后在点击sumProjects按钮时，我把这个代码

Private Sub CommandButton1_Click()
    Dim lngLR As Long
    Dim wb As Workbook
    Dim sh, sourceSheet As Worksheet
    Dim i, x as Integer

    With Me
        lngLR = .Cells(.Rows.Count, "A").End(xlUp).Row 'finds the last row of column A
    End With

    'creates a new worksheet with the name of the given year
    With ThisWorkbook
        Set sh = .Worksheets.Add(after:=.Sheets(.Sheets.Count))
        sh.Name = (Range("D2").Value)
    End With

    x = 1 'this will be used to keep track if which row to input
          'data on the destination sheet, we set it to 1 because
          'we know the destination sheet is a new sheet so we know
          'where the first row is, we do not have to calculate it

    'loops through all of the project names in column A
    'looking for one that contains the year given in D2
    For i = 1 To lngLR
        'look for year in project name 
        If InStr(Range("A" & i), Range("D2")) Then
            'project of given year found. Open workbook and get data
            Set wb = Application.Workbooks.Open("C:\Desktop\" & Range("A" & i) & ".xlsx")
            Set sourceSheet = wb.Worksheets(1)
            sh.Range("C" & x).Value = sourceSheet.Range("D5").Value
            x = x + 1 'x is only incremented when a value is placed on the new sheet
            wb.Close
        End If
    Next i 
End Sub
于 2013-04-05T14:04:33.547 回答
0

所以我编辑了loveforvdubs代码以满足我的需要。我确信工作表模板的复制可以更优雅地解决，但我无法得到任何其他解决方案。

再次感谢loveforvdubs的帮助！

Private Sub CommandButton1_Click()
Dim lngLR As Long
Dim wb As Workbook
Dim sh, sourceSheet As Worksheet

If Len(Me.TextBox1 & "") = 0 Then   ' If TextBox1 is empty returns Msg
    MsgBox ("Bitte Jahr eingeben")
Else
    With Me
        lngLR = .Cells(.Rows.Count, "A").End(xlUp).Row 'finds the last row of column A
    End With

    'creates a new worksheet with the name of the given year
    With ThisWorkbook
        Worksheets("Auswertung").Visible = True
        Worksheets("Auswertung").Select
        Worksheets("Auswertung").Copy After:=Sheets(1)
        Worksheets("Auswertung (2)").Select
        Worksheets("Auswertung (2)").Name = TextBox1
        Worksheets("Auswertung").Visible = False
        Set sh = Worksheets(2)
    End With

    'loops through all of the project names in column A
    'looking for one that contains the year given in TextBox1
    For i = 1 To lngLR
        'look for year in project name
        If InStr(Range("A" & i), TextBox1) Then
            'project of given year found. Open workbook and get data
            Set wb = Application.Workbooks.Open("K:\Projektplanung\Projektkosten\" & Range("A" & i) & "_" & Range("B" & i) & ".xlsx")
            Set sourceSheet = wb.Worksheets(1)
            sh.Range("A" & i).Value = sourceSheet.Range("I30").Value
            wb.Close
        End If
    Next i
End If
End Sub
于 2013-04-08T11:09:08.460 回答