excel - Excel VBAループ列、strの検索、開いているワークブックの検索、セル範囲のコピー

Question

少し問題があります。私は製品開発に携わっており、年間 100 以上のプロジェクトを管理しています。特定のプロジェクトの実行時間は流動的で、計画よりも時間がかかるものもあれば、それよりも早いものもあります。すべてのプロジェクトについて、時間/コストワークブックが計画されたコスト/時間で設定され、プロジェクトが完了すると、実際のコスト/時間が帰属されます。これまで、すべての表は手動で作成、入力、およびフォルダーに保存されていました。ファイルに同じ名前が付けられることはなく、最終的に異なるタイトル形式になります。これにより、プロジェクトの年間平均コスト/実行時間を確認することが非常に困難になります。

アイデアは、時間/コストワークブックの作成をより簡単にすることです。

ワークフロー:

ワークブック「プロジェクト」を開く
Project-Nr.: xxx-yyyy-zz を列 A に入力します (xxx = Project-Nr. | yyyy = year | zz = Project-type)
列 B にプロジェクト名を入力します
プロジェクトヒットボタン「Create_Open」で行を選択
テンプレートを使用して新しいワークブックが作成されます
プロジェクト番号および Project-Name が Template にコピーされます
ワークブックはファイル名で保存されます (プロジェクト番号 "_" プロジェクト名 ".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 のすべての行をループします。

ワークフロー:

ボタンクリックでユーザーウィンドウ「年を入力」を開く
年を入力せずにOKボタンをクリックするとエラーが返る
年号入力 OKボタンをクリック
入力した年のタイトルで新しいワークシートを作成する
列 A で年が検索されます。
プロジェクトワークブックを開いた対応する年からプロジェクトが見つかった場合
ワークブックからセル範囲をコピーする
セルの範囲を手順 4 のワークシートの Project list Workbook に貼り付けます
手順 6 で開いたブックを閉じる
セルが空になるまで 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

どんな助けでも大歓迎です。

score 0 · Accepted Answer

だから私は自分のニーズに合わせて 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 - Excel VBAループ列、strの検索、開いているワークブックの検索、セル範囲のコピー

2 に答える 2

Related

Reference