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

Question

Im totally new to VBA and a little lost here. I have an Excel file with the holidays of my colleagues. There is a cell for every day of the year, where they need to put in an "X". I need to write a macro with VBA to export a CSV file, which exports their personnel number and the start- and enddate of their vacation. I also need a logic to skip weekends. I need the CSV File to import it to Visual Planning. It should be a table, with personnel number, start date and end date as columns How can i do that? Can you help me please?

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

End Sub

This is the code i got so far, but I need to copy the "X"es dynamically into my CSV Sheet.

Answer 1

Please, try the next code. It builds a string respecting the CSV creation rule and put it in a file at the end. The file name will be importEmployee.csv and it will be found on the workbooks keeping this code path. You can change the path in whatever you need (at the end code part):

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

Please, send some feedback after testing it.