lionheart

Because the code extracts the unique values from column c regardless the order of the months. After the execution of the code you can cut the columns and reorder the results according to your needs

Try Sub Test() Dim lr As Long With ActiveSheet lr = .Cells(Rows.Count, 1).End(xlUp).Row ConvertData .Range("A1:D" & lr), .Range("H1") End With End Sub Public Sub ConvertData(ByVal sourceRange As Range, ByVal targetCell As Range) Const NAME_COL As Long = 2, MONTH_COL As Long = 3 Dim vName, vMonth, outputRange As Range, dicName As Object, dicMonth As Object, i As Long Set dicName = CreateObject("Scripting.Dictionary") Set dicMonth = CreateObject("Scripting.Dictionary") For i = 2 To sourceRange.Rows.Count If Not dicName.Exists(sourceRange(i, NAME_COL).Value) Then dicName.Add sourceRange(i, NAME_COL).Value, dicName.Count + 1 End If If Not dicMonth.Exists(sourceRange(i, MONTH_COL).Value) Then dicMonth.Add sourceRange(i, MONTH_COL).Value, dicMonth.Count + 1 End If Next i Set outputRange = targetCell.Resize(dicName.Count + 1, dicMonth.Count + 2) outputRange.Cells(1, 1).Value = "S" outputRange.Cells(1, 2).Value = "Name" For Each vMonth In dicMonth.Keys outputRange.Cells(1, dicMonth(vMonth) + 2).Value = vMonth Next vMonth For Each vName In dicName.Keys outputRange.Cells(dicName(vName) + 1, 1).Value = dicName(vName) outputRange.Cells(dicName(vName) + 1, 2).Value = vName For Each vMonth In dicMonth.Keys For i = 2 To sourceRange.Rows.Count If sourceRange(i, NAME_COL).Value = vName And sourceRange(i, MONTH_COL).Value = vMonth Then outputRange.Cells(dicName(vName) + 1, dicMonth(vMonth) + 2).Value = sourceRange(i, 4).Value Exit For End If Next i Next vMonth Next vName End Sub

Post a new topic for the new question

In standard module Private Declare Function IsNetworkAlive Lib "Sensapi" (lpdwFlags As Long) As Long Sub CheckInternetConnection() If Not IsInternetConnected() Then UserForm1.Show Application.OnTime Now + TimeValue("00:00:10"), "CheckInternetConnection" End Sub Public Function IsInternetConnected() As Boolean Dim lngAlive If IsNetworkAlive(lngAlive) = 1 Then IsInternetConnected = True End Function In workbook module Private Sub Workbook_Open() Application.OnTime Now + TimeValue("00:00:10"), "CheckInternetConnection" End Sub

Not so clear but try Sub Test() Dim c As Range For Each c In Range("A1").CurrentRegion.Cells If IsNumeric(c.Value) Then c.Value = c.Value + 1 Next c End Sub

Select the column of your desire Data tab > Text to Columns > Next > Uncheck Tab option > Next > Select Text option > Finish

The data don't seem to be logical at all Please attach a file with some logical data to know the real strucuture of the data

Tomorrow I will have a look as I am not available now

For Excel 365, use the following formula in cell D11 (Clear the range first from D11 to D25) then put the formula =TEXT(FILTER(SEQUENCE(DAY(EOMONTH(K6,0)),,EOMONTH(K6,-1)+1,1),WEEKDAY(SEQUENCE(DAY(EOMONTH(K6,0)),,EOMONTH(K6,-1)+1,1),1)>=6),"ddd") In cell E11, use the formula =TEXT(FILTER(SEQUENCE(DAY(EOMONTH(K6,0)),,EOMONTH(K6,-1)+1,1),WEEKDAY(SEQUENCE(DAY(EOMONTH(K6,0)),,EOMONTH(K6,-1)+1,1),1)>=6),"dd/mm/yyyy") For older version of excel ------------------------------- In cell D11, use the formula =IF(MONTH($K$6-MOD(WEEKDAY($K$6,1)-6-IF(WEEKDAY(DATE(YEAR($K$6),MONTH($K$6),1),1)=7,1,0),7)+IF(WEEKDAY($K$6,1)<6,7,0)+7*(INT((ROW()-11)/2)))=MONTH($K$6),$K$6-MOD(WEEKDAY($K$6,1)-6-IF(WEEKDAY(DATE(YEAR($K$6),MONTH($K$6),1),1)=7,1,0),7)+IF(WEEKDAY($K$6,1)<6,7,0)+7*(INT((ROW()-11)/2)),"") In cell D12, use the formula =IFERROR(IF(MONTH(IF(WEEKDAY(E11)=6,E11+1,IF(WEEKDAY(E11)=7,E11+6,"")))>MONTH($K$6),"",IF(WEEKDAY(E11)=6,E11+1,IF(WEEKDAY(E11)=7,E11+6,""))),"") Select the cells D11 & D12 and drag them Do the same exactly for E11 & E12

When you drag any formula it will be applied to all the cells in the column What purpose of avoiding the hidden cells not to have the formula

I don't have any more to introduce in this topic If you really need help, attach an excel file not csv file with some data and the desired output exactly

Not clear at all

I didn't get exactly what you mean Generally, you can imitate the desired card by creating a card manually then to have a look at it and modify the code according to your requirement I think you already have the solution for both creating vcards and exporting them to outlook

No need to change the headers to get what you need. I have opened outlook on my side and imitate creating VCards and this is the new working code for the first attachment and this will save the fields properly for you Sub Create_VCARDS() Dim ws As Worksheet, FirstName As String, LastName As String, FullName As String, Mobile As String, HomePhone As String, BusinessPhone As String, Email As String, vCard As String, sFolder As String, sFileName As String, lr As Long, i As Long Application.ScreenUpdating = False Set ws = ActiveSheet lr = ws.Cells(Rows.Count, "A").End(xlUp).Row sFolder = ThisWorkbook.Path & "\VCARDS\" If Len(Dir(sFolder, vbDirectory)) = 0 Then MkDir sFolder For i = 2 To lr With ws FirstName = .Cells(i, 1).Value LastName = .Cells(i, 2).Value FullName = FirstName & " " & LastName Mobile = .Cells(i, 3).Value HomePhone = .Cells(i, 4).Value BusinessPhone = .Cells(i, 5).Value Email = .Cells(i, 6).Value End With vCard = "BEGIN:VCARD" & vbCrLf vCard = vCard & "VERSION:3.0" & vbCrLf vCard = vCard & "N:" & LastName & ";" & FirstName & vbCrLf vCard = vCard & "FN:" & FullName & vbCrLf vCard = vCard & "TEL;TYPE=CELL:" & Mobile & vbCrLf vCard = vCard & "TEL;TYPE=HOME:" & HomePhone & vbCrLf vCard = vCard & "TEL;TYPE=WORK:" & BusinessPhone & vbCrLf vCard = vCard & "EMAIL;TYPE=INTERNET:" & Email & vbCrLf vCard = vCard & "END:VCARD" & vbCrLf sFileName = sFolder & FullName & ".vcf" Open sFileName For Output As #1 Print #1, vCard Close #1 Next i Application.ScreenUpdating = True MsgBox "Done", 64 End Sub The code will create a folder with the name `VCARDS` at the same path of your workbook and it will contains all the VCFs --------------------------------------------------------------------- Now after creating the VCards, you can use late binding in the code you attached to export all the VCards to Outlook at one shot. I prefer to get the outlook application open before executing the code Sub Save_VCARDS_To_OutLook() Dim fso As Object, fsDir As Object, fsFile As Object, objOL As Object, colInsp As Object, objWSHShell As Object, sFolder As String, strVCName As String sFolder = ThisWorkbook.Path & "\VCARDS" Set fso = CreateObject("Scripting.FileSystemObject") Set fsDir = fso.GetFolder(sFolder) For Each fsFile In fsDir.Files strVCName = """" & sFolder & "\" & fsFile.Name & """" Set objOL = CreateObject("Outlook.Application") Set colInsp = objOL.Inspectors If colInsp.Count = 0 Then Set objWSHShell = CreateObject("WScript.Shell") objWSHShell.Run strVCName Set colInsp = objOL.Inspectors If Err = 0 Then Do Until colInsp.Count = 1 DoEvents Loop colInsp.Item(1).CurrentItem.Save colInsp.Item(1).Close olDiscard Set colInsp = Nothing: Set objWSHShell = Nothing End If End If Set objOL = Nothing Next fsFile Set fsFile = Nothing: Set fsDir = Nothing: Set fso = Nothing MsgBox "Done", 64 End Sub

I didn't work on outlook but I think there must be a way to import the VCF from outlook at one shot

Try this code Sub Test() Dim ws As Worksheet, FirstName As String, LastName As String, FullName As String, Mobile As String, HomePhone As String, BusinessPhone As String, Email As String, vCard As String, sFolder As String, sFileName As String, lr As Long, i As Long Application.ScreenUpdating = False Set ws = ActiveSheet lr = ws.Cells(Rows.Count, "A").End(xlUp).Row sFolder = ThisWorkbook.Path & "\VCARDS\" If Len(Dir(sFolder, vbDirectory)) = 0 Then MkDir sFolder For i = 2 To lr With ws FirstName = .Cells(i, 1).Value LastName = .Cells(i, 2).Value FullName = FirstName & " " & LastName Mobile = .Cells(i, 3).Value HomePhone = .Cells(i, 4).Value BusinessPhone = .Cells(i, 5).Value Email = .Cells(i, 6).Value End With vCard = "BEGIN:VCARD" & vbCrLf vCard = vCard & "VERSION:3.0" & vbCrLf vCard = vCard & "N:" & LastName & ";" & FirstName & vbCrLf vCard = vCard & "FN:" & FullName & vbCrLf vCard = vCard & "TEL;TYPE=CELL:" & Mobile & vbCrLf vCard = vCard & "TEL;TYPE=CELL:" & HomePhone & vbCrLf vCard = vCard & "TEL;TYPE=CELL:" & BusinessPhone & vbCrLf vCard = vCard & "EMAIL;TYPE=INTERNET:" & Email & vbCrLf vCard = vCard & "END:VCARD" & vbCrLf sFileName = sFolder & FullName & ".vcf" Open sFileName For Output As #1 Print #1, vCard Close #1 Next i Application.ScreenUpdating = True MsgBox "Done", 64 End Sub

Great. It should work well as you used UTF-8 Can you upload the systool excel conveter you used? and why didn't you use excel vba code for that purpose Also upload sample of the desired vcard

I think you specified the wrong reply as the best answer. This is not useful for other members

How did you get the csv file? what is the code dis you use or the csv file is the raw data and you need to convert the data in it to vcard More details are required if you really need help

Sorry Use the line without this part : GoTo Skipper The line should be Columns(sColTarget).Rows(FirstRow & ":" & FirstRow + 1).ClearContents You have to be able to fix such issues by yourself

Update the office from File menu > Account > Update options > Update Now

Attach sample of the file and the csv output. Also post the code you used to convert the data to csv file to have a look

Change thi line If Target.Value = Empty Then Columns(sColTarget).Rows(FirstRow & ":" & FirstRow + 1).ClearContents: GoTo Skipper To be Columns(sColTarget).Rows(FirstRow & ":" & FirstRow + 1).ClearContents: GoTo Skipper

Try the last point by yourself You can use conditional formatting to do that task

Suppose the cells are B1 & B2 for the year and the month, try the following code in worksheet change event Private Sub Worksheet_Change(ByVal Target As Range) Const FirstRow As Long = 4, FirstColumn As Long = 3, numColumns As Long = 366, sColTarget As String = "C:ND" Dim results(1 To 2, 1 To numColumns), yearValue As Long, currentDate As Date, lastDate As Date, i As Long, selectedMonth As Long, col As Long If Target.Address = "$B$1" Then If Target.Value = Empty Then Columns(sColTarget).Rows(FirstRow & ":" & FirstRow + 1).ClearContents: GoTo Skipper On Error Resume Next yearValue = CInt(Target.Value) On Error GoTo 0 If IsDate("01/01/" & yearValue) Then currentDate = DateSerial(yearValue, 1, 1) lastDate = DateSerial(yearValue + 1, 1, 1) - 1 i = 0 While currentDate <= lastDate i = i + 1 results(1, i) = Format(currentDate, "ddd") results(2, i) = Format(currentDate, "yyyy-mm-dd") currentDate = currentDate + 1 Wend Application.EnableEvents = False Application.ScreenUpdating = False Range(Cells(FirstRow, FirstColumn), Cells(FirstRow + 1, FirstColumn + i - 1)).Value = results Application.ScreenUpdating = True Application.EnableEvents = True Else MsgBox "Please Enter Valid Year", vbExclamation End If ElseIf Target.Address = "$B$2" Then If Target.Value = Empty Then GoTo Skipper On Error Resume Next selectedMonth = Left(Target.Value, InStr(Target.Value, ".") - 1) On Error GoTo 0 If selectedMonth <> 0 Then Application.EnableEvents = False Application.ScreenUpdating = False Columns(sColTarget).Hidden = True For col = FirstColumn To numColumns + (FirstColumn - 1) If IsDate(Cells(FirstRow + 1, col).Value) Then If Month(Cells(FirstRow + 1, col).Value) = selectedMonth Then Cells(FirstRow + 1, col).EntireColumn.Hidden = False End If Next col Application.ScreenUpdating = True Application.EnableEvents = True End If End If Exit Sub Skipper: Application.EnableEvents = False Columns(sColTarget).Hidden = False Application.EnableEvents = True End Sub