Vba to convert csv (insert cells)

[KGEORGE13]

Hello,

I am going to be importing a CSV file into a sheet weekly and need the column to line up properly. The Comma Seperated list I am importing does not account for spaces I need for the excel sheet. I made a dummy table below. Every person is ordering a shirt, a hat, shoes, or any combination of the three. To the right is how many they are ordering. I need to run a macro to shift cells from the shirt column if they don't equal shirt, while also keeping the quantities. Basically I want the first table to turn into the 2nd table by running a VBA. The order will always be SHIRT - HAT - SHOES

NAME	SHIRT?	QTY	HAT?	QTY	SHOES?	QTY
kyle	Shirt	1	Shoes	2
john	Shoes	5
jack	Shirt	3	Hat	1	Shoes	2
kevin	Hat	2	Shoes	1

<tbody>
</tbody>

NAME	SHIRT?	QTY	HAT?	QTY?	SHOES?	QTY
kyle	Shirt	1			Shoes	2
john					Shoes	5
jack	Shirt	3	Hat		Shoes	3
kevin			Hat	2	Shoes	1

<tbody>
</tbody>

Anything Helps


THANK YOU!!!

 

[Sajukai]

So you're saying your CSV import for row 3 would be
john,shoes,5
instead of the proper format of
john,,,,,shoes,5

Correct? (I'm assuming your delimiter is comma)

 

[DanteAmor]

I give you the macro
The result will be on a sheet of the book where you have the macro.
Put the name of this sheet in this line: Set h1 = Sheets ("sheets9").
On that sheet, on line 1, put the headings of your products.
Put the book with the macro and the csv book in the same folder.
Put the name of the csv in this line: arch = "book5.csv"



You can have more products in the csv and the macro will put them in the column on the right.
Try and tell me

Sub Vba_to_convert_csv()
    '
    Application.ScreenUpdating = False
    '
    Dim l1 As Workbook, l2 As Workbook
    Dim h1 As Worksheet, h2 As Worksheet
    Dim ruta As String, arch As String
    Dim i As Long, u2 As Long, j As Long, k As Long, uc1 As Long, uc2 As Long
    '
    Set l1 = ThisWorkbook
    Set h1 = Sheets("sheets9")  'name of your sheet to put the result
    '
    ruta = l1.Path & "\"
    arch = "book5.csv"         'name of csv to import
    '
    If Dir(ruta & arch) = "" Then
        MsgBox "File does not exist"
        Exit Sub
    End If
    '
    Set l2 = Workbooks.Open(Filename:=ruta & arch)
    Set h2 = l2.Sheets(1)
    '
    h1.Rows("2:" & Rows.Count).ClearContents
    k = 2
    u2 = h2.Range("A" & Rows.Count).End(xlUp).Row
    For i = 2 To u2
        uc2 = h2.Cells(i, Columns.Count).End(xlToLeft).Column
        For j = 2 To uc2 Step 2
            ord = h2.Cells(i, j).Value
            qty = h2.Cells(i, j + 1).Value
            Set b = h1.Rows(1).Find(ord, lookat:=xlPart, LookIn:=xlValues)
            If Not b Is Nothing Then
                uc1 = b.Column
            Else
                uc1 = h1.Cells(1, Columns.Count).End(xlToLeft).Column + 1
                h1.Cells(1, uc1).Value = h2.Cells(i, "A").Value
                h1.Cells(1, uc1 + 1).Value = "QTY"
            End If
            '
            h1.Cells(k, "A").Value = h2.Cells(i, "A").Value
            h1.Cells(k, uc1).Value = ord
            h1.Cells(k, uc1 + 1).Value = qty
        Next
        k = k + 1
    Next
    '
    l2.Close False
    Set l1 = Nothing: Set h1 = Nothing
    Set l2 = Nothing: Set h2 = Nothing
    Application.ScreenUpdating = True
    '
    MsgBox "End"
End Sub

Let me know is you have any question.

 

[KGEORGE13]

Hello, I was wondering if you could help with this same worksheet.

I decided to use the code below and it works pretty well. The only thing wrong is that it doesn't shift cells in the first 2 rows like I would like. Also, I get an error when trying to save if i edit anything in the first two rows.

Any suggestions??

Thank You!

Sub SHIFT_SAVE()
Dim i As Long, LastRow As Long, Rng As Range

'On Error GoTo ErrMsg

' CHECKING COLUMN K. IF VALUE = X , 4 CELLS WILL BE INSERTED AND X AND VALUE WILL SHIFT TO RIGHT

LastRowK1 = ActiveSheet.Cells(Rows.Count, "K").End(xlUp).Row
Set Rng = Range("K1:K" & LastRowK1)
For i = Rng.Cells.Count To 2 Step -1
    With Rng.Cells(i)
        If .Value = "X" Then
           .Select
           Selection.Insert SHIFT:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
           Selection.Insert SHIFT:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
           Selection.Insert SHIFT:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
           Selection.Insert SHIFT:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
            
        End If
    End With
Next i


' CHECKING COLUMN K. IF VALUE = Y , 2 CELLS WILL BE INSERTED AND Y AND VALUE WILL SHIFT TO RIGHT


LastRowK2 = ActiveSheet.Cells(Rows.Count, "K").End(xlUp).Row
Set Rng = Range("K1:K" & LastRowK2)
For i = Rng.Cells.Count To 2 Step -1
    With Rng.Cells(i)
        If .Value = "Y" Then
           .Select
           Selection.Insert SHIFT:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
           Selection.Insert SHIFT:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
           
            
        End If
    End With
Next i


' CHECKING COLUMN M. IF VALUE = X , 2 CELLS WILL BE INSERTED AND X AND VALUE WILL SHIFT TO RIGHT


LastRowM = ActiveSheet.Cells(Rows.Count, "M").End(xlUp).Row
Set Rng = Range("M1:M" & LastRowM)
For i = Rng.Cells.Count To 2 Step -1
    With Rng.Cells(i)
        If .Value = "X" Then
           .Select
           Selection.Insert SHIFT:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
           Selection.Insert SHIFT:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
           
            
        End If
    End With
Next i

 'SAVE******************************************************************************************************
 
Dim NewSht As Worksheet
Dim fName1 As String

fName1 = Range("R2").Value

Application.DisplayAlerts = False
Set NewSht = ThisWorkbook.Worksheets.Add
fName = "U:\Desktop\" & fName1 & ".csv"   ' <----- PLACE DESIRED SAVE PATH BETWEEN FIRST SET OF QUOTATIONS
NewSht.SaveAs fName, xlCSV
NewSht.Delete
Application.DisplayAlerts = True


    Range("R1:Z3").Select
    Selection.Clear
    ActiveWorkbook.Save
    
 'SAVE*******************************************************************************************************
    
Range("A1").Select
    
 
  '  ActiveWorkbook.Close True
    





Exit Sub

' THIS MESSAGE WILL SHOW EVERYTIME THERE IS AN ERROR (NOT JUST WHEN NO FILE NAME IS TYPED IN
ErrMsg:
MsgBox ("You did not enter a new file name in CELL R2. Select the  sheet and run the Macro again. No copy and pasting is necessary."), , "NO FILE NAME FOUND"



End Sub

 

[DanteAmor]

If your macro has problems, then it does not work pretty well.
Did you try with my macro?
Try and tell me.

 

[KGEORGE13]

The reason your macro is not working for what I'm trying to accomplish is because I need to use this continuously. The user is going to manually copy and past the csv file onto this sheet and run the macro, then resave it as a csv.

 

[DanteAmor]

Then I remove the part of opening the file from my macro and add the part of saving the file as csv.