使用VBA从Excel导出CSV并导入到Visual Planning中

Question

我对VBA完全是个新手，在这里有点迷茫。我有一个Excel文件，里面有我同事的假期。一年中的每一天都有一个单元格，他们需要在其中放一个"X“。我需要用VBA写一个宏来导出CSV文件，该文件导出他们的人员编号以及假期的开始日期和结束日期。我还需要一个跳过周末的逻辑。我需要CSV文件将其导入Visual Planning。它应该是一个表，以人员编号、开始日期和结束日期为列，我该怎么做？你能帮帮我吗？

​

​

Sub Makro1()

‘

Dim wb As Workbook
Dim ws As Worksheet
Set wb = ActiveWorkbook
Set ws = Worksheets("2021")

Dim ersteZeile As Integer
Dim letzteZeile As Integer

Dim c As Range
Dim datumRow As Integer
Dim d As Range

datumRow = 4


ersteZeile = 5
letzteZeile = ws.UsedRange.SpecialCells(xlCellTypeLastCell).Row

anfangsRange = "I" & ersteZeile
endrange = "NI" & letzteZeile

For Each c In ws.Range("I5:NI71")
    If Not c.Value = "" Then
        Cells(4, c.Column).Copy Destination:=Sheets("CSV").Column("BEGDA")
    End If
Next c

结束子对象

这就是我到目前为止得到的代码，但我需要将“X”动态复制到我的CSV表中。

Answer 1

请尝试下一个代码。它构建一个符合CSV创建规则的字符串，并在最后将其放入一个文件中。文件名将是importEmployee.csv，它将在工作簿中找到，并保留此代码路径。您可以根据需要更改路径(在末尾代码部分)：

Sub ExportCSVHolidayDays()
 Dim sh As Worksheet, lastRow As Long, lastCol As Long, arrPn, arrH, arrInt
 Dim i As Long, j As Long, strCSV As String, startD As String, endD As String
 Dim lngSt As Long, lngEnd As Long, arrI
 
 Set sh = ActiveSheet
 lastRow = sh.Range("A" & rows.count).End(xlUp).row
 lastCol = sh.cells(4, Columns.count).End(xlToLeft).Column
 
 arrPn = sh.Range("A5:A" & lastRow).Value
 arrH = sh.Range("H4", sh.cells(lastRow, lastCol)).Value
 
 For i = 1 To UBound(arrPn)
    arrInt = Application.Index(arrH, i + 1, 0)       'extract a row slice of arrH
    arrI = Split(StrReverse(Join(arrInt, ",")), ",") 'reverse the slice array
    
     lngSt = WorksheetFunction.Match("X", arrInt, 0) 'first "X" position
    startD = arrH(1, lngSt): ' start date (from arrH first row)
     lngEnd = UBound(arrI) - WorksheetFunction.Match("X", arrI, 0) + 2 'last "X" pos
    endD = arrH(1, lngEnd):  ' end date (from arrH first row)
    
    If strCSV = "" Then
        'write the first row of the CSV string - first employee
        strCSV = arrPn(i, 1) & "," & startD & "," & endD & vbCrLf
    Else
        'next employee first line
        strCSV = strCSV & arrPn(i, 1) & "," & startD & "," & endD & vbCrLf
    End If
        startD = "": endD = ""                            'reinitialize the variables
        For j = lngSt To lngEnd + 1
            If UCase(arrInt(j)) = "X" And startD = "" Then startD = arrH(1, j)          'new start date
            If arrInt(j) = "" And endD = "" And startD <> "" Then endD = arrH(1, j - 1) 'new end date
            
            If endD <> "" Then
                'write the sequence inside the total start and end date
                strCSV = strCSV & arrPn(i, 1) & "," & startD & "," & endD & vbCrLf
            End If
            If arrInt(j) = "" Then startD = "": endD = "" 'reinitialize the variables
        Next
 Next
 'write the CSV file from string (strCSV):
 Dim expPath As String
 expPath = ThisWorkbook.Path & "\importEmployee.csv"
 Open expPath For Output As #1
    Print #1, strCSV
 Close #1
 MsgBox "Ready..." & vbCrLf & _
        "Here you can find he CSV exported file: " & expPath & ".", _
                            vbInformation, "Finishing confirmation"
End Sub

请在测试后发送一些反馈。