[Okta Webinar] Learn how to a build a cloud-first strategyRegister Now

x
?
Solved

EXCEL 2007

Posted on 2012-08-25
15
Medium Priority
?
380 Views
Last Modified: 2012-08-27
Hello,
I've been using below macro for a while, but I need to adjust a bit.

Based on Column "A", IF cell is Empty:
- coy value for Empty cells in Column "A"  from cell in previous Row.
- Replace Column "O" with "RMA"
- fill Column "S" with "0.01"

Option Explicit
Public Sub ImportAndSplitDeliveryANDReturnCombined()
    Dim wkb As Workbook
    Dim rngSrc As Range
    Dim rngCell As Range
    Dim rngTgt As Range
    Dim rngUsed As Range
    Dim strPath As String
    Application.ScreenUpdating = False
    'Open the file as fixed length data
    Workbooks.OpenText Filename:="C:\Users\user.DOMAIN\Desktop\File01.out", Origin:=437, _
        StartRow:=1, DataType:=xlFixedWidth, FieldInfo:=Array(Array(0, 1), _
        Array(8, 1), Array(14, 2), Array(29, 1), Array(39, 1), Array(55, 1), Array(63, 1), _
        Array(163, 1), Array(213, 1), Array(263, 1), Array(307, 1), Array(353, 1), Array(393, 1), _
        Array(403, 1), Array(418, 1), Array(422, 2), Array(439, 2), Array(451, 2), _
        Array(466, 1)), TrailingMinusNumbers:=True
    strPath = ActiveWorkbook.Path
    Set rngUsed = ActiveSheet.Range([A1], ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell))
    'Trim column I
    For Each rngCell In rngUsed.Columns(9).Cells
        rngCell.Value = Left(rngCell.Value, Len(rngCell.Value) - 3)
    Next
    'Zero out the time component of the date/time value in column Q
    For Each rngCell In rngUsed.Columns(17).Cells
        rngCell.Value = Left(rngCell.Value, 12) & ""
   
    Next
    Set wkb = ActiveWorkbook
    wkb.SaveAs strPath & "\Combined01", XlFileFormat.xlCSV, , , , , , xlLocalSessionChanges
    wkb.Close False
    Application.ScreenUpdating = True
   
End Sub

Any help is appreciated.
0
Comment
Question by:W.E.B
  • 9
  • 6
15 Comments
 

Author Comment

by:W.E.B
ID: 38333071
Please see sample attached (I changed the extension from .out to .txt)
File01.txt
0
 

Author Comment

by:W.E.B
ID: 38333145
PLease note,
Column "A" ,all cells have the same value. (DATE)
So empty cells in Column "A" can have the same value of any other cell in the same Column "A".
0
 
LVL 17

Expert Comment

by:andrewssd3
ID: 38333940
Try this - I have made a couple of minor changes to your original code, but mainly have just added the functionality you wanted.  I assume at least one cell in col A will contain a date, if not I use today's date - you could change this obviously if that's not what you want
Option Explicit

Public Sub ImportAndSplitDeliveryANDReturnCombined()
    Dim wkb As Workbook
    Dim wks As Worksheet
    Dim rngSrc As Range
    Dim rngCell As Range
    Dim rngTgt As Range
    Dim rngUsed As Range
    Dim strPath As String
    Dim strDate As String

    Application.ScreenUpdating = False
    
    'Open the file as fixed length data
    Workbooks.OpenText Filename:="C:\Users\user.DOMAIN\Desktop\File01.out", Origin:=437, _
        StartRow:=1, DataType:=xlFixedWidth, FieldInfo:=Array(Array(0, 1), _
        Array(8, 1), Array(14, 2), Array(29, 1), Array(39, 1), Array(55, 1), Array(63, 1), _
        Array(163, 1), Array(213, 1), Array(263, 1), Array(307, 1), Array(353, 1), Array(393, 1), _
        Array(403, 1), Array(418, 1), Array(422, 2), Array(439, 2), Array(451, 2), _
        Array(466, 1)), TrailingMinusNumbers:=True
    
    Set wkb = ActiveWorkbook
    strPath = wkb.Path
    Set wks = wkb.ActiveSheet
    Set rngUsed = wks.Range([A1], ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell))
    
    'Trim column I
    For Each rngCell In rngUsed.Columns(9).Cells
        rngCell.Value = Left(rngCell.Value, Len(rngCell.Value) - 3)
    Next rngCell
    
    'Zero out the time component of the date/time value in column Q
    For Each rngCell In rngUsed.Columns(17).Cells
        rngCell.Value = Left(rngCell.Value, 12) & ""
    Next rngCell
    
    ' find a non-blank value in col A (simplest to look for the last)
    Set rngCell = wks.Cells(wks.Rows.Count, rngUsed.Column).End(xlUp)
    ' if we found a cell with a value, use it; otherwise use today's date
    strDate = Trim$(rngCell.Value)
    If Len(strDate) = 0 Then
        strDate = Format(Int(Now), "yyyymmdd")
    End If
    rngUsed.Columns(1).Cells.Value = strDate
    
    ' Fill column O
    rngUsed.Columns(15).Cells.Value = "RMA"
    
    ' Fill column S
    rngUsed.Columns(19).Cells.Value = 0.01
    
    wkb.SaveAs strPath & "\Combined01", XlFileFormat.xlCSV, , , , , , xlLocalSessionChanges
    wkb.Close False
    Application.ScreenUpdating = True
    
End Sub

Open in new window

0
Technology Partners: We Want Your Opinion!

We value your feedback.

Take our survey and automatically be enter to win anyone of the following:
Yeti Cooler, Amazon eGift Card, and Movie eGift Card!

 

Author Comment

by:W.E.B
ID: 38334135
Thanks Andrew,
2 small issues,

    ' Fill column O
    rngUsed.Columns(15).Cells.Value = "RMA"
   
    ' Fill column S
    rngUsed.Columns(19).Cells.Value = 0.01

this should only apply if cell in Column "A" was blank.

thanks
0
 
LVL 17

Expert Comment

by:andrewssd3
ID: 38334474
Sorry - misread the question - try this:
Public Sub ImportAndSplitDeliveryANDReturnCombined()
    Dim wkb As Workbook
    Dim wks As Worksheet
    Dim rngSrc As Range
    Dim rngCell As Range
    Dim rngTgt As Range
    Dim rngUsed As Range
    Dim strPath As String
    Dim strDate As String

    Application.ScreenUpdating = False
    
    'Open the file as fixed length data
    Workbooks.OpenText Filename:="C:\Users\stuart\Desktop\File01.out", Origin:=437, _
        StartRow:=1, DataType:=xlFixedWidth, FieldInfo:=Array(Array(0, 1), _
        Array(8, 1), Array(14, 2), Array(29, 1), Array(39, 1), Array(55, 1), Array(63, 1), _
        Array(163, 1), Array(213, 1), Array(263, 1), Array(307, 1), Array(353, 1), Array(393, 1), _
        Array(403, 1), Array(418, 1), Array(422, 2), Array(439, 2), Array(451, 2), _
        Array(466, 1)), TrailingMinusNumbers:=True
    
    Set wkb = ActiveWorkbook
    strPath = wkb.Path
    Set wks = wkb.ActiveSheet
    Set rngUsed = wks.Range([A1], ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell))
    
    'Trim column I
    For Each rngCell In rngUsed.Columns(9).Cells
        rngCell.Value = Left(rngCell.Value, Len(rngCell.Value) - 3)
    Next rngCell
    
    'Zero out the time component of the date/time value in column Q
    For Each rngCell In rngUsed.Columns(17).Cells
        rngCell.Value = Left(rngCell.Value, 12) & ""
    Next rngCell
    
    ' find a non-blank value in col A (simplest to look for the last)
    Set rngCell = wks.Cells(wks.Rows.Count, rngUsed.Column).End(xlUp)
    ' if we found a cell with a value, use it; otherwise use today's date
    strDate = Trim$(rngCell.Value)
    If Len(strDate) = 0 Then
        strDate = Format(Int(Now), "yyyymmdd")
    End If
    
    For Each rngCell In rngUsed.Columns(1).Cells
        If Len(Trim$(rngCell.Value)) = 0 Then
        
            rngCell.Value = strDate
            ' Fill column O
            rngCell.Offset(0, 14).Value = "RMA"
            
            ' Fill column S
            rngCell.Offset(0, 18).Value = 0.01
        End If
    Next rngCell
    
    
'    wkb.SaveAs strPath & "\Combined01", XlFileFormat.xlCSV, , , , , , xlLocalSessionChanges
'    wkb.Close False
    Application.ScreenUpdating = True
    
End Sub

Open in new window

0
 

Author Comment

by:W.E.B
ID: 38334477
Hello,
Sorry to be a pain,
but,
    ' Fill column O
    rngUsed.Columns(15).Cells.Value = "RMA"

on the original out file, it has a plus sign (+RMA), if you can remove the + sign, then probelm solved and it will be RMA after I run the code..

Thanks,
0
 
LVL 17

Expert Comment

by:andrewssd3
ID: 38334483
Do you mean remove the + from any line that has +RMA, even if the date is there?  Is it just +RMA, or could there be different strings? I could remove the + from any string in that column.
0
 

Author Comment

by:W.E.B
ID: 38334505
Hello Andrew,
 I could remove the + from any string in that column.
if you can do this, this will solve future issues I might encounter.

I will increase the points to 500.
Are you able to split the output files based on Column "O"

example:

Column "O" -- RG .. output file will be File01
Column "O" -- RMA .. output file will be File02

Thanks.
0
 
LVL 17

Expert Comment

by:andrewssd3
ID: 38334535
OK - give me a couple of hours.  I think your last change will warrant the extra points!
0
 

Author Comment

by:W.E.B
ID: 38334537
THANKS
0
 
LVL 17

Accepted Solution

by:
andrewssd3 earned 2000 total points
ID: 38334776
This is probably not quite how I'd do it from scratch, but retaining most of your original code, here is the split:
Public Sub ImportAndSplitDeliveryANDReturnCombined()
    Dim wkb As Workbook
    Dim wks As Worksheet
    Dim rngSrc As Range
    Dim rngCell As Range
    Dim rngTgt As Range
    Dim rngUsed As Range
    Dim strPath As String
    Dim strDate As String
    Dim strTemp As String

    Dim aOut As Variant
    Dim aOut1 As Variant
    Dim aOut2 As Variant
    Dim lngOutRow As Long
    Dim lngOut1Row As Long
    Dim lngOut2Row As Long
    Dim j As Long


    Application.ScreenUpdating = False
    
    'Open the file as fixed length data
    Workbooks.OpenText Filename:="C:\Users\stuart\Desktop\File01.out", Origin:=437, _
        StartRow:=1, DataType:=xlFixedWidth, FieldInfo:=Array(Array(0, 1), _
        Array(8, 1), Array(14, 2), Array(29, 1), Array(39, 1), Array(55, 1), Array(63, 1), _
        Array(163, 1), Array(213, 1), Array(263, 1), Array(307, 1), Array(353, 1), Array(393, 1), _
        Array(403, 1), Array(418, 1), Array(422, 2), Array(439, 2), Array(451, 2), _
        Array(466, 1)), TrailingMinusNumbers:=True
    
    Set wkb = ActiveWorkbook
    strPath = wkb.Path
    Set wks = wkb.ActiveSheet
    Set rngUsed = wks.Range([A1], ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell))
    
    'Trim column I
    For Each rngCell In rngUsed.Columns(9).Cells
        rngCell.Value = Left(rngCell.Value, Len(rngCell.Value) - 3)
    Next rngCell
    
    'Zero out the time component of the date/time value in column Q
    For Each rngCell In rngUsed.Columns(17).Cells
        rngCell.Value = Left(rngCell.Value, 12) & ""
    Next rngCell
    
    ' find a non-blank value in col A (simplest to look for the last)
    Set rngCell = wks.Cells(wks.Rows.Count, rngUsed.Column).End(xlUp)
    ' if we found a cell with a value, use it; otherwise use today's date
    strDate = Trim$(rngCell.Value)
    If Len(strDate) = 0 Then
        strDate = Format(Int(Now), "yyyymmdd")
    End If
    
    For Each rngCell In rngUsed.Columns(1).Cells
        If Len(Trim$(rngCell.Value)) = 0 Then
        
            rngCell.Value = strDate
            ' Fill column O
            rngCell.Offset(0, 14).Value = "RMA"
            
            ' Fill column S
            rngCell.Offset(0, 18).Value = 0.01
        End If
    Next rngCell
    
    ' remove a + sign from the start of column O if present
    For Each rngCell In rngUsed.Columns(15).Cells
        strTemp = rngCell.Value
        If Left(strTemp, 1) = "+" Then
            rngCell.Value = Mid(strTemp, 2)
        End If
    Next rngCell
    
    ' now split the file into two depending on the value of column O
    aOut = rngUsed.Value
    ' define temp arrays for each one - make each big enoug to hold the maximum
    ReDim aOut1(1 To UBound(aOut, 1), 1 To UBound(aOut, 2))
    ReDim aOut2(1 To UBound(aOut, 1), 1 To UBound(aOut, 2))
    
    lngOut1Row = 1
    lngOut2Row = 1
    
    For lngOutRow = 1 To UBound(aOut, 1)
        Select Case aOut(lngOutRow, 15)
            Case "RG"
                ' take all columns to the first output array
                For j = 1 To UBound(aOut, 2)
                    aOut1(lngOut1Row, j) = "'" & aOut(lngOutRow, j)
                Next j
                lngOut1Row = lngOut1Row + 1
            Case "RMA"
                ' take all columns to the second output array
                For j = 1 To UBound(aOut, 2)
                    aOut2(lngOut2Row, j) = "'" & aOut(lngOutRow, j)
                Next j
                lngOut2Row = lngOut2Row + 1
            Case Else
                ' can there be other values?
        End Select
    Next lngOutRow
    
    ' finished with the main range - clear it
    rngUsed.EntireRow.Delete
    
    ' write the first output if any rows found
    If lngOut1Row > 1 Then
        wks.Cells(1).Resize(lngOut1Row - 1, UBound(aOut, 2)).Value = aOut1
        wkb.SaveAs strPath & "\Combined01", XlFileFormat.xlCSV, , , , , , xlLocalSessionChanges
    End If
    
    wks.UsedRange.EntireRow.Delete
    ' write the second output if any rows found
    If lngOut2Row > 1 Then
        wks.Cells(1).Resize(lngOut2Row - 1, UBound(aOut, 2)).Value = aOut2
        wkb.SaveAs strPath & "\Combined02", XlFileFormat.xlCSV, , , , , , xlLocalSessionChanges
    End If
    
    
'    wkb.SaveAs strPath & "\Combined01", XlFileFormat.xlCSV, , , , , , xlLocalSessionChanges
    wkb.Close False
    Application.ScreenUpdating = True
    
End Sub

Open in new window

0
 

Author Comment

by:W.E.B
ID: 38334846
Hello,
thank you for your time,
I should have said that RG and RMA are not the only 2 codes in Column "O".

The out put files, should be:
RMA is one outputfile
All other codes in Column "O" is the other output file.

what's happening now is,
if Date in Column "A" --- then it is changing Column "O" to RG
if NO Date in Column "A" --- then it is changing Column "O" to RMA

Can you please help.
thanks.
0
 

Author Comment

by:W.E.B
ID: 38334899
All good,
I figured it out.
I hope this is it.

thank you very much.for your time and help.
0
 

Author Closing Comment

by:W.E.B
ID: 38334902
thank you very much.
I hope this is it.
I'll wait for my client feedback.
0
 
LVL 17

Expert Comment

by:andrewssd3
ID: 38335653
Thanks for the points - glad to help.  If you have any further question, prob best to post on a new question as this gives everyone a chance to pitch their solution!
0

Featured Post

Independent Software Vendors: We Want Your Opinion

We value your feedback.

Take our survey and automatically be enter to win anyone of the following:
Yeti Cooler, Amazon eGift Card, and Movie eGift Card!

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

Microsoft's Excel has many features that most people will never need nor take advantage of.  Conditional formatting is one feature that you may find a necessity once you start using it.
Windows Explorer let you handle zip folders nearly as any other folder: Copy, move, change, and delete, etc. In VBA you can also handle normal files and folders, but zip folders takes a little more - and that you'll find here.
This Micro Tutorial demonstrates in Microsoft Excel how to consolidate your marketing data by creating an interactive charts using form controls. This creates cool drop-downs for viewers of your chart to choose from.
Excel styles will make formatting consistent and let you apply and change formatting faster. In this tutorial, you'll learn how to use Excel's built-in styles, how to modify styles, and how to create your own. You'll also learn how to use your custo…

834 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question