Question

我有点问题。我从事产品开发并每年管理100多个项目，给定项目的运行时间流畅，有些需要更长时间，然后计划完成，其他项目更快。对于每个项目，时间/成本工作簿都按计划成本/时间设置，然后在项目完成后，实际成本/时间被估算。到目前为止，每个表都已手动创建，填写并保存到文件夹，文件从未命名相同，最终得到不同的标题格式。这使得很难审查项目的年平均成本/运行时间。

我们的想法是简化时间/成本工作簿的创建。

工作流程：

打开工作簿“项目”
在A栏输入Project-Nr。：xxx-yyyy-zz （xxx = Project-Nr。| yyyy = year | zz =项目类型）
在B列中输入项目名称
选择带有项目点按钮的行“Create_Open”
使用模板
项目-NR。和项目名称被复制到模板
工作簿以文件名保存（Project-Nr。“_”Project-Name“.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的所有行，直到它到达空行。

工作流：

Buttonclick打开用户窗口“输入年份”
单击没有年份输入的确定按钮返回错误
输入年份cick OK按钮
创建标题为输入年份的新工作表
搜索A列年份。
从项目工作簿开启的相应年份找到项目
从工作簿
将单元格范围粘贴到第4步工作表中的项目列表工作簿
在第6步中打开关闭工作簿
循环5-9直到emty cell

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

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

非常感谢任何帮助。

Answer 1

希望这会有所帮助。我尝试了一个测试，我认为我非常接近你的问题。我有一个projectList工作簿，在第一页上我在A列中有以下值

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

然后我有一个名为sumProjects的按钮，在单元格D2中我有一年的总和。对于上面的每个项目名称，我创建了一个名为相同的电子表格，在这些电子表格中，我将一些数据放在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

Answer 2

所以我编辑了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

Excel VBA循环列，搜索str，查找打开的工作簿，复制单元格范围

2 个答案: