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

x
?
Solved

Transfer Data from Master Worksheet to New Worksheet

Posted on 2012-08-19
9
Medium Priority
?
659 Views
Last Modified: 2012-08-28
Hi All,

I am receiving a text file every month, with the help of one of your experts, I got solution to extract text data to summary sheet as per below code:
Sub FileExtract()
Dim LastRow1 As Long
Dim LastRow2 As Long
Dim ws As Worksheet
Dim content As Worksheet
Dim result As String
Dim data_range As String

    Application.DisplayAlerts = False
    
    '-- this code is placed in a module, so first make sure that we are working on the summary sheet.
    Set ws = Worksheets("summary")
    ws.Select
    
    ws.Cells(ws.Rows.Count, "H").End(xlUp).Font.bold = False
    ws.Cells(ws.Rows.Count, "I").End(xlUp).Font.bold = False
    ws.Cells(ws.Rows.Count, "J").End(xlUp).Font.bold = False
    
    '-- clear data cells
    data_range = Replace(ws.UsedRange.Address, "$A$1", "A5")
    Range(data_range).ClearContents
    
    '-- select data file
    result = Application.GetOpenFilename(FileFilter:="Monthly Data files, *.txt", Title:="Please Select A File")
    If result <> CStr(False) Then Workbooks.OpenText filename:=result _
        , Origin:=437, StartRow:=1, DataType:=xlFixedWidth, FieldInfo:=Array( _
        Array(0, 1), Array(40, 1), Array(46, 1), Array(52, 1), Array(56, 1), _
        Array(64, 1), Array(68, 1), Array(98, 1), Array(111, 1), Array(124, 1), Array(137, 1), _
        Array(142, 1), Array(155, 1), Array(160, 1), Array(185, 1), Array(191, 1), Array(199, 1), _
        Array(224, 1), Array(227, 1), Array(231, 1), Array(234, 1), Array(238, 1), Array(240, 1), _
        Array(245, 1), Array(247, 1), Array(261, 1), Array(270, 1), Array(290, 1), Array(296, 1), _
        Array(309, 1), Array(321, 1), Array(332, 1), Array(336, 1), Array(341, 1), Array(344, 1), _
        Array(386, 1), Array(408, 1), Array(472, 1), Array(526, 1), Array(536, 1), Array(576, 1), _
        Array(599, 1), Array(645, 1), Array(666, 1)), TrailingMinusNumbers:=True
    DoEvents
    Set content = Workbooks(Mid(result, InStrRev(result, "\") + 1)).ActiveSheet
    
    '-- add headers
    content.Range("A1").EntireRow.Insert
    content.Range("F:F").Insert
    content.Range("C1") = "Corp"
    content.Range("D1") = "Area"
    content.Range("E1") = "Acct"
    content.Range("F1") = "Type"
    content.Range("G1") = "PCNT"
    content.Range("N1") = "Cust.No."
    content.Range("M1") = "Net"
    content.Range("P1") = "Inv.No."
    content.Range("AJ1") = "Vessels"
    content.Range("AJ1") = "Type"
    
    '-- remove totals from column AJ
    content.Columns("AJ:AJ").AutoFilter
    content.Rows("1:1").AutoFilter field:=1, Criteria1:="=*total*", Operator:=xlAnd
    content.UsedRange.Offset(1).Delete shift:=xlUp
    content.Rows("1:1").AutoFilter
    
    '-- insert account type lookup formulae
    LastRow1 = Cells(Rows.Count, "P").End(xlUp).Row
    content.Range("F2:F" & LastRow1).Formula = "=VLOOKUP(RC[-1],'[CommCalc.xls]Account-Type'!C1:C2,2,0)"
    content.Range("F:F").Copy
    content.Range("F:F").PasteSpecial xlPasteValues
    
    '-- find zero values
    content.Range("M2:M" & LastRow1).Formula = "=IF(RC[-3]=0,RC[-4],IF(RC[-3]>0,RC[-3],""""))"
    content.Range("M:M").Copy
    content.Range("M:M").PasteSpecial xlPasteValues
        
    '-- remove zero values from column M
    content.Columns("M:M").AutoFilter
    content.Rows("1:1").AutoFilter field:=1, Criteria1:="=0", Operator:=xlAnd
    content.UsedRange.Offset(1).Delete shift:=xlUp
    content.Rows("1:1").AutoFilter
    
    '-- sort data
    content.UsedRange.Sort Key1:=Range("F2"), Order1:=xlAscending, Header:=xlYes
           
    '-- sort data by vessels
    content.UsedRange.Sort Key1:=Range("H2"), Order1:=xlAscending, Header:=xlYes
    
    '-- keep only revenue types
    content.Rows("1:1").AutoFilter
    content.Rows("1:1").AutoFilter field:=6, Criteria1:="<>*revenue*", Operator:=xlAnd
    content.UsedRange.Offset(1).Delete shift:=xlUp
    content.Rows("1:1").AutoFilter
    
    '-- delete other revenue types
    content.Rows("1:1").AutoFilter
    content.Rows("1:1").AutoFilter field:=6, Criteria1:="OTHER REVENUE"
    content.UsedRange.Offset(1).Delete shift:=xlUp
    content.Rows("1:1").AutoFilter

    '-- add vessel name row
    content.Range("AV2:AV" & LastRow1).Formula = "=CONCATENATE(RC[-12],RC[-11],RC[-10],RC[-9],RC[-8],RC[-7],RC[-6],RC[-5],RC[-4],RC[-3],RC[-2])"
    content.Columns("AV").Copy
    content.Columns("AV").PasteSpecial xlPasteValues

    '-- remove maintenance from column AV
    content.Columns("AV:AV").AutoFilter
    content.Rows("1:1").AutoFilter field:=1, Criteria1:="=*maintenance*", Operator:=xlAnd
    content.UsedRange.Offset(1).Delete shift:=xlUp
    content.Rows("1:1").AutoFilter
    
    '-- remove taut from column AV
    content.Columns("AV:AV").AutoFilter
    content.Rows("1:1").AutoFilter field:=1, Criteria1:="=*taut*", Operator:=xlAnd
    content.UsedRange.Offset(1).Delete shift:=xlUp
    content.Rows("1:1").AutoFilter

    '-- copy remaining data
    content.UsedRange.Offset(1).Columns(5).Copy
    ws.Range("B5").PasteSpecial xlValues
    content.UsedRange.Offset(1).Columns(3).Copy
    ws.Range("C5").PasteSpecial xlValues
    content.UsedRange.Offset(1).Columns(4).Copy
    ws.Range("D5").PasteSpecial xlValues
    content.UsedRange.Offset(1).Columns(7).Copy
    ws.Range("E5").PasteSpecial xlValues
    content.UsedRange.Offset(1).Columns(36).Copy
    ws.Range("F5").PasteSpecial xlValues
    content.UsedRange.Offset(1).Columns(6).Copy
    ws.Range("G5").PasteSpecial xlValues
    content.UsedRange.Offset(1).Columns(9).Copy
    ws.Range("H5").PasteSpecial xlValues
    content.UsedRange.Offset(1).Columns(10).Copy
    ws.Range("I5").PasteSpecial xlValues
    content.UsedRange.Offset(1).Columns(14).Copy
    ws.Range("K5").PasteSpecial xlValues
    content.UsedRange.Offset(1).Columns(16).Copy
    ws.Range("L5").PasteSpecial xlValues
    content.UsedRange.Offset(1).Columns(48).Copy
    ws.Range("M5").PasteSpecial xlValues
    
    '-- add function
    LastRow2 = ws.Cells(ws.Rows.Count, "B").End(xlUp).Row
    ws.Range("A5").Formula = "1"
    ws.Range("A6").Formula = "=A5+1"
    ws.Range("A6").AutoFill ws.Range("A6:A" & LastRow2)
    ws.Range("A6:A" & LastRow2).Copy
    ws.Range("A6:A" & LastRow2).PasteSpecial xlValues
    ws.Range("J5:J" & LastRow2).Formula = "=I5-H5"
    ws.Range("J5:J" & LastRow2).Copy
    ws.Range("J5:J" & LastRow2).PasteSpecial xlValues
    ws.Range("H" & LastRow2 + 2).Formula = "=SUBTOTAL(9,H5:H" & LastRow2 & ")"
    ws.Range("H" & LastRow2 + 2).Font.bold = True
    ws.Range("I" & LastRow2 + 2).Formula = "=SUBTOTAL(9,I5:I" & LastRow2 & ")"
    ws.Range("I" & LastRow2 + 2).Font.bold = True
    ws.Range("J" & LastRow2 + 2).Formula = "=SUBTOTAL(9,J5:J" & LastRow2 & ")"
    ws.Range("J" & LastRow2 + 2).Font.bold = True
    ws.Range("F4:F" & LastRow2).Replace What:="Charter hire of ", Replacement:="", LookAt:= _
        xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
        
    '-- close data file
    content.Parent.Close False
    ws.AutoFilterMode = False
    Application.Goto ws.Range("A5:A" & LastRow2), True
    ws.Range("B3").Formula = Mid(result, 26, 7)
    ws.Columns("A:A").EntireColumn.AutoFit
    ws.Columns("F:F").EntireColumn.AutoFit
    ws.Cells(ws.Rows.Count, "J").End(xlUp).Select
    Application.DisplayAlerts = True
    
    
End Sub

Open in new window


Now I would like to copy this data to new worksheet in the same workbook for specific customer number "85175" adding "1000" in the beginning, it will look like "100085175" and renaming new sheet as "CABGOC" and copy rest of the data to copy another new sheet with the same format of customer number and renaming as "NON-CABGOC".

Please help....
0
Comment
Question by:Shums
  • 7
9 Comments
 
LVL 28

Author Comment

by:Shums
ID: 38309855
Hi All,

One more thing I would like to add, after running above code, I would like to have msgbox or userform to ask user "Summary Sheet Is Completed, Do You Want To Continue....", if "Yes" then continue with my request creating new sheets, if "No" end sub.
0
 
LVL 8

Expert Comment

by:Elton Pascua
ID: 38310262
Quite honestly, in most cases, debugging a code is more difficult than writing one because you have to understand the logic behind it. Can you reference the previous question in EE? Or maybe post a sample of the completed output (after running the macro).
0
 
LVL 18

Accepted Solution

by:
Jose Parrot earned 1500 total points
ID: 38310299
Hello,

As we are not supposed to write the code, we should support you with our best guidance and help you to achieve your needs, so I'll try to provide solutions for each step.

Assuming you have the "summary" worksheet loaded as per your spectations.
1. Create a new Worksheet:
Worksheets.Add(Before, After, Count, Type)
Example: Worksheets.Add(3,,2,xlWorksheet) for create, before sheet 3, two new simple worksheets. The simplest call to such is
Worksheets.Add()    <--- without arguments. Tis will create one single worksheet before the Active worksheet.
You can crete a new one and naming it directly:
ActiveWorkbook.Worksheets.Add
ActiveSheet.Name="CABGOC"

2. Copy data of selected customer
First, find it in the appropriate column ("A" for instance).
The code at http://www.techonthenet.com/excel/macros/search_for_string.php has what you are looking for: to find the string (your customer numer) and to copy the row to CABGOC worksheet. For each inverse condition, say, the ones that don't match the customer numer, you can copy to NON-CABGOC.
To switch from CABGOC to NON-CABGOC and vice-versa as target just make them active, as in http://stackoverflow.com/questions/10502524/copy-rows-to-a-new-worksheet-vba

3. Change the customer numberIn this case you should concatenate the strings:
newStr = "1000" & custNumber  ' If custNumber is 85175, then result is 100085175
If customer number isn't a string, but an long number instead, then should be computed as
newNumber = 100000000 + custNumber
My suggestion is to treat them as strings.
In any case, to make the change you should work directly with the target cell:
Sheets("CABGOC").Cells(rowN, colN) = newNumber  'being rowN and colN the row and column of the target cell.

Hope it is useful and help you to start ypur own coding.

Jose
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!

 
LVL 28

Author Comment

by:Shums
ID: 38310734
Thanks Jose,

I will try with your referred links and come back to you. Could you also advice me how to get a msg box or user form before starting second part?

Hi Techfanatic,

Attached is my sample file as final output. For ws.Range("B3").Formula = Mid(result, 26, 7), you need to create a directory Account Recon in C:/ as it will read the mid result for "C:\Account Recon".

After running above code in sheet "Summary", for now I am manually copying/moving it to CABGOC & NON-CABGOC.

Thank you in advance
CommDat-2012-06.txt
CommCalc.xls
0
 
LVL 28

Assisted Solution

by:Shums
Shums earned 0 total points
ID: 38316378
Jose,

I simply added two different sheet permanently instead of add.worksheet and incorporated below code; its working perfectly fine, but it doesn't clearcontents from Cabcog & non-Cabgoc worksheet before pasting for different month. Please advice....

Sub FullSummary()

Dim LastRow1 As Long
Dim LastRow2 As Long
Dim ws As Worksheet, wsR As Worksheet, wsC As Worksheet, wsNC As Worksheet
Dim content As Worksheet
Dim result As String
Dim data_range As String
Dim data_range1 As String
Dim data_range2 As String
Dim ReturnValue As Integer
Dim strTemp As String

    Application.DisplayAlerts = False
    
    '-- this code is placed in a module, so first make sure that we are working on the summary sheet.
    Set ws = Worksheets("Summary")
    ws.Select
    
    ws.Cells(ws.Rows.Count, "H").End(xlUp).Font.bold = False
    ws.Cells(ws.Rows.Count, "I").End(xlUp).Font.bold = False
    ws.Cells(ws.Rows.Count, "J").End(xlUp).Font.bold = False
    
    '-- clear data cells
    data_range = Replace(ws.UsedRange.Address, "$A$1", "A5")
    Range(data_range).ClearContents
    
    '-- select data file
    result = Application.GetOpenFilename(FileFilter:="Monthly Data files, *.txt", Title:="Please Select A File")
    If result <> CStr(False) Then Workbooks.OpenText filename:=result _
        , Origin:=437, StartRow:=1, DataType:=xlFixedWidth, FieldInfo:=Array( _
        Array(0, 1), Array(40, 1), Array(46, 1), Array(52, 1), Array(56, 1), _
        Array(64, 1), Array(68, 1), Array(98, 1), Array(111, 1), Array(124, 1), Array(137, 1), _
        Array(142, 1), Array(155, 1), Array(160, 1), Array(185, 1), Array(191, 1), Array(199, 1), _
        Array(224, 1), Array(227, 1), Array(231, 1), Array(234, 1), Array(238, 1), Array(240, 1), _
        Array(245, 1), Array(247, 1), Array(261, 1), Array(270, 1), Array(290, 1), Array(296, 1), _
        Array(309, 1), Array(321, 1), Array(332, 1), Array(336, 1), Array(341, 1), Array(344, 1), _
        Array(386, 1), Array(401, 1)), TrailingMinusNumbers:=True
    DoEvents
    Set content = Workbooks(Mid(result, InStrRev(result, "\") + 1)).ActiveSheet
    strTemp = Mid$(result, InStrRev(result, "\") + 1)
    
    '-- add headers
    content.Range("A1").EntireRow.Insert
    content.Range("F:F").Insert
    content.Range("C1") = "Corp"
    content.Range("D1") = "Area"
    content.Range("E1") = "Acct"
    content.Range("F1") = "Type"
    content.Range("G1") = "PCNT"
    content.Range("N1") = "Cust.No."
    content.Range("M1") = "Net"
    content.Range("P1") = "Inv.No."
    content.Range("AJ1") = "Vessels"
    
    '-- remove unwanted text
    content.Columns("AJ:AJ").Replace What:="=- ", Replacement:="", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
    
    '-- remove totals from column AK
    content.Columns("AK:AK").AutoFilter
    content.Rows("1:1").AutoFilter Field:=1, Criteria1:="=*total*", Operator:=xlAnd
    content.UsedRange.Offset(1).Delete Shift:=xlUp
    content.Rows("1:1").AutoFilter
    
    '-- insert account type lookup formulae
    
    LastRow1 = Cells(Rows.Count, "P").End(xlUp).Row
    content.Range("F2:F" & LastRow1).Formula = "=VLOOKUP(RC[-1],'[CommCalc(1).xls]Account-Type'!C1:C2,2,0)"
    content.Range("F:F").Copy
    content.Range("F:F").PasteSpecial xlPasteValues
    
    '-- find zero values
    content.Range("M2:M" & LastRow1).Formula = "=IF(RC[-3]=0,RC[-4],IF(RC[-3]>0,RC[-3],""""))"
    content.Range("M:M").Copy
    content.Range("M:M").PasteSpecial xlPasteValues
        
    '-- remove zero values from column M
    content.Columns("M:M").AutoFilter
    content.Rows("1:1").AutoFilter Field:=1, Criteria1:="=0", Operator:=xlAnd
    content.UsedRange.Offset(1).Delete Shift:=xlUp
    content.Rows("1:1").AutoFilter
    
    '-- sort data
    content.UsedRange.Sort Key1:=Range("F2"), Key2:=Range("H2"), Order1:=xlAscending, Header:=xlYes
           
    '-- add vessel name row
    content.Range("AV2:AV" & LastRow1).Formula = "=CONCATENATE(RC[-12],RC[-11],RC[-10],RC[-9],RC[-8],RC[-7],RC[-6],RC[-5],RC[-4],RC[-3],RC[-2])"
    content.Columns("AV").Copy
    content.Columns("AV").PasteSpecial xlPasteValues

    '-- copy remaining data
    content.UsedRange.Offset(1).Columns(5).Copy
    ws.Range("B5").PasteSpecial xlValues
    content.UsedRange.Offset(1).Columns(3).Copy
    ws.Range("C5").PasteSpecial xlValues
    content.UsedRange.Offset(1).Columns(4).Copy
    ws.Range("D5").PasteSpecial xlValues
    content.UsedRange.Offset(1).Columns(7).Copy
    ws.Range("E5").PasteSpecial xlValues
    content.UsedRange.Offset(1).Columns(36).Copy
    ws.Range("F5").PasteSpecial xlValues
    content.UsedRange.Offset(1).Columns(6).Copy
    ws.Range("G5").PasteSpecial xlValues
    content.UsedRange.Offset(1).Columns(9).Copy
    ws.Range("H5").PasteSpecial xlValues
    content.UsedRange.Offset(1).Columns(10).Copy
    ws.Range("I5").PasteSpecial xlValues
    content.UsedRange.Offset(1).Columns(14).Copy
    ws.Range("K5").PasteSpecial xlValues
    content.UsedRange.Offset(1).Columns(16).Copy
    ws.Range("L5").PasteSpecial xlValues
    content.UsedRange.Offset(1).Columns(48).Copy
    ws.Range("M5").PasteSpecial xlValues
    
    '-- add function
    LastRow2 = ws.Cells(ws.Rows.Count, "B").End(xlUp).Row
    ws.Range("A5").Formula = "1"
    ws.Range("A6").Formula = "=A5+1"
    ws.Range("A6").AutoFill ws.Range("A6:A" & LastRow2)
    ws.Range("A6:A" & LastRow2).Copy
    ws.Range("A6:A" & LastRow2).PasteSpecial xlValues
    ws.Range("J5:J" & LastRow2).Formula = "=I5-H5"
    ws.Range("J5:J" & LastRow2).Copy
    ws.Range("J5:J" & LastRow2).PasteSpecial xlValues
    ws.Range("H" & LastRow2 + 2).Formula = "=SUBTOTAL(9,H5:H" & LastRow2 & ")"
    ws.Range("H" & LastRow2 + 2).Font.bold = True
    ws.Range("I" & LastRow2 + 2).Formula = "=SUBTOTAL(9,I5:I" & LastRow2 & ")"
    ws.Range("I" & LastRow2 + 2).Font.bold = True
    ws.Range("J" & LastRow2 + 2).Formula = "=SUBTOTAL(9,J5:J" & LastRow2 & ")"
    ws.Range("J" & LastRow2 + 2).Font.bold = True
    ws.Range("F4:F" & LastRow2).Replace What:="Charter hire of ", Replacement:="", LookAt:= _
        xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
        
    '-- close data file
    
    ws.AutoFilterMode = False
    Application.Goto ws.Range("A5:A" & LastRow2), True
    ws.Range("B3") = Left$(strTemp, InStrRev(strTemp, ".") - 1)
    ws.Columns("A:A").EntireColumn.AutoFit
    ws.Columns("F:F").EntireColumn.AutoFit
    ws.Columns("G:G").EntireColumn.AutoFit
    ws.Cells(ws.Rows.Count, "J").End(xlUp).Select
        
    '-- this code is placed in a module, so first make sure that we are working on the Revenue sheet.
    Set wsR = Worksheets("Revenue_Summary")
    Set wsC = Worksheets("CABGOC")
    Set wsNC = Worksheets("NON-CABGOC")
    wsR.Select
    
    wsR.Cells(wsR.Rows.Count, "H").End(xlUp).Font.bold = False
    wsR.Cells(wsR.Rows.Count, "I").End(xlUp).Font.bold = False
    wsR.Cells(wsR.Rows.Count, "J").End(xlUp).Font.bold = False
    
    '-- clear data cells for Revenue_Summary
    data_range = Replace(wsR.UsedRange.Address, "$A$1", "A5")
    Range(data_range).ClearContents
   
    DoEvents
    content.Activate
    
    '-- sort data by vessels
    content.UsedRange.Sort Key1:=Range("H2"), Order1:=xlAscending, Header:=xlYes
    
    '-- keep only revenue types
    content.Rows("1:1").AutoFilter
    content.Rows("1:1").AutoFilter Field:=6, Criteria1:="<>*revenue*", Operator:=xlAnd
    content.UsedRange.Offset(1).Delete Shift:=xlUp
    content.Rows("1:1").AutoFilter
    
    '-- delete other revenue types
    content.Rows("1:1").AutoFilter
    content.Rows("1:1").AutoFilter Field:=6, Criteria1:="OTHER REVENUE"
    content.UsedRange.Offset(1).Delete Shift:=xlUp
    content.Rows("1:1").AutoFilter

    '-- remove maintenance from column AV
    content.Columns("AV:AV").AutoFilter
    content.Rows("1:1").AutoFilter Field:=1, Criteria1:="=*maintenance*", Operator:=xlAnd
    content.UsedRange.Offset(1).Delete Shift:=xlUp
    content.Rows("1:1").AutoFilter
    
    '-- remove taut from column AV
    content.Columns("AV:AV").AutoFilter
    content.Rows("1:1").AutoFilter Field:=1, Criteria1:="=*taut*", Operator:=xlAnd
    content.UsedRange.Offset(1).Delete Shift:=xlUp
    content.Rows("1:1").AutoFilter

    '-- copy remaining data
    content.UsedRange.Offset(1).Columns(5).Copy
    wsR.Range("B5").PasteSpecial xlValues
    content.UsedRange.Offset(1).Columns(3).Copy
    wsR.Range("C5").PasteSpecial xlValues
    content.UsedRange.Offset(1).Columns(4).Copy
    wsR.Range("D5").PasteSpecial xlValues
    content.UsedRange.Offset(1).Columns(7).Copy
    wsR.Range("E5").PasteSpecial xlValues
    content.UsedRange.Offset(1).Columns(36).Copy
    wsR.Range("F5").PasteSpecial xlValues
    content.UsedRange.Offset(1).Columns(6).Copy
    wsR.Range("G5").PasteSpecial xlValues
    content.UsedRange.Offset(1).Columns(9).Copy
    wsR.Range("H5").PasteSpecial xlValues
    content.UsedRange.Offset(1).Columns(10).Copy
    wsR.Range("I5").PasteSpecial xlValues
    content.UsedRange.Offset(1).Columns(14).Copy
    wsR.Range("K5").PasteSpecial xlValues
    content.UsedRange.Offset(1).Columns(16).Copy
    wsR.Range("L5").PasteSpecial xlValues
    content.UsedRange.Offset(1).Columns(48).Copy
    wsR.Range("M5").PasteSpecial xlValues
    
    '-- add function
    LastRow2 = wsR.Cells(wsR.Rows.Count, "B").End(xlUp).Row
    wsR.Range("A5").Formula = "1"
    wsR.Range("A6").Formula = "=A5+1"
    wsR.Range("A6").AutoFill wsR.Range("A6:A" & LastRow2)
    wsR.Range("A6:A" & LastRow2).Copy
    wsR.Range("A6:A" & LastRow2).PasteSpecial xlValues
    wsR.Range("J5:J" & LastRow2).Formula = "=I5-H5"
    wsR.Range("J5:J" & LastRow2).Copy
    wsR.Range("J5:J" & LastRow2).PasteSpecial xlValues
    wsR.Range("H" & LastRow2 + 2).Formula = "=SUBTOTAL(9,H5:H" & LastRow2 & ")"
    wsR.Range("H" & LastRow2 + 2).Font.bold = True
    wsR.Range("I" & LastRow2 + 2).Formula = "=SUBTOTAL(9,I5:I" & LastRow2 & ")"
    wsR.Range("I" & LastRow2 + 2).Font.bold = True
    wsR.Range("J" & LastRow2 + 2).Formula = "=SUBTOTAL(9,J5:J" & LastRow2 & ")"
    wsR.Range("J" & LastRow2 + 2).Font.bold = True
    wsR.Range("F4:F" & LastRow2).Replace What:="Charter hire of ", Replacement:="", LookAt:= _
        xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
        
    '-- close data file
    content.Parent.Close False
    wsR.AutoFilterMode = False
    Application.Goto wsR.Range("A5:A" & LastRow2), True
    wsR.Range("B3") = Left$(strTemp, InStrRev(strTemp, ".") - 1)
    wsC.Range("B3") = Left$(strTemp, InStrRev(strTemp, ".") - 1)
    wsNC.Range("B3") = Left$(strTemp, InStrRev(strTemp, ".") - 1)
    wsR.Columns("A:A").EntireColumn.AutoFit
    wsR.Columns("F:F").EntireColumn.AutoFit
    Call SearchForCabGoc
    Call SearchForNonCabGoc
    wsR.Activate
    wsR.Cells(wsR.Rows.Count, "J").End(xlUp).Select
    Application.DisplayAlerts = True
        
End Sub
Sub SearchForCabGoc()

    Dim LSearchRow As Integer
    Dim LCopyToRow As Integer
    
    On Error GoTo Err_Execute
    
    'Start search in row 5
    LSearchRow = 5
    
    'Start copying data to row 5 in CABGOC (row counter variable)
    LCopyToRow = 5
    
    While Len(Range("A" & CStr(LSearchRow)).Value) > 0
        
        'If value in column K = "85175", copy entire row to CABGOC
        If Range("K" & CStr(LSearchRow)).Value = "85175" Then
            
            'Select row in Revenue_Summary to copy
            Rows(CStr(LSearchRow) & ":" & CStr(LSearchRow)).Select
            Selection.Copy
            
            'Paste row into CABGOC in next row
            Sheets("CABGOC").Select
            Rows(CStr(LCopyToRow) & ":" & CStr(LCopyToRow)).Select
            ActiveSheet.Paste
            
            'Move counter to next row
            LCopyToRow = LCopyToRow + 1
            
            'Go back to Revenue_Summary to continue searching
            Sheets("Revenue_Summary").Select
            
        End If
        
        LSearchRow = LSearchRow + 1
        
    Wend
    
    Exit Sub
    
Err_Execute:
    MsgBox "An Error Occurred."
    
End Sub
Sub SearchForNonCabGoc()

    Dim LSearchRow As Integer
    Dim LCopyToRow As Integer
    
    On Error GoTo Err_Execute
    
    'Start search in row 5
    LSearchRow = 5
    
    'Start copying data to row 5 in NON-CABGOC (row counter variable)
    LCopyToRow = 5
    
    While Len(Range("A" & CStr(LSearchRow)).Value) > 0
        
        'If value in column K <> "85175", copy entire row to NON-CABGOC
        If Range("K" & CStr(LSearchRow)).Value <> "85175" Then
            
            'Select row in Revenue_Summary to copy
            Rows(CStr(LSearchRow) & ":" & CStr(LSearchRow)).Select
            Selection.Copy
            
            'Paste row into CABGOC in next row
            Sheets("NON-CABGOC").Select
            Rows(CStr(LCopyToRow) & ":" & CStr(LCopyToRow)).Select
            ActiveSheet.Paste
            
            'Move counter to next row
            LCopyToRow = LCopyToRow + 1
            
            'Go back to Revenue_Summary to continue searching
            Sheets("Revenue_Summary").Select
            
        End If
        
        LSearchRow = LSearchRow + 1
        
    Wend
    
    MsgBox "All CABGOC & NON-CABGOC Customer Data Has Been Copied."
        
    Exit Sub
    
Err_Execute:
    MsgBox "An Error Occurred."
    
End Sub

Open in new window


Thanking You in advance.
0
 
LVL 28

Author Comment

by:Shums
ID: 38316466
I was trying to incorporate below with the above by adding LastRow3 & LastRow4, but I am failing, please help:

    'add function
    wsC.Column("G:I").Delete Shift:=xlToLeft
    wsC.Column("H:H").EntireColumn.Insert Shift:=xlToRight
    LastRow3 = wsC.Cells(wsC.Rows.Count, "B").End(xlUp).Row
    wsC.Range("A5").Formula = "1"
    wsC.Range("A6").Formula = "=A5+1"
    wsC.Range("A6").AutoFill wsC.Range("A6:A" & LastRow3)
    wsC.Range("A6:A" & LastRow3).Copy
    wsC.Range("A6:A" & LastRow3).PasteSpecial xlValues
    wsC.Range("H5:H" & LastRow3).Formula = "=RC[-1]*10%"
    wsC.Range("H5:H" & LastRow3).Copy
    wsC.Range("H5:H" & LastRow3).PasteSpecial xlValues
    wsC.Column("K:K").Delete Shift:=xlToLeft
        
    '-- add headers
    wsC.Range("A4") = "Seq"
    wsC.Range("B4") = "ACCT"
    wsC.Range("C4") = "CORP"
    wsC.Range("D4") = "AREA"
    wsC.Range("E4") = "PCNT"
    wsC.Range("F4") = "Vessel Name"
    wsC.Range("G4") = "Amount"
    wsC.Range("H4") = "Comm_Amt"
    wsC.Range("I4") = "Cust_No."
    wsC.Range("J4") = "Inv.No."
    wsC.Range("G" & LastRow3 + 2).Formula = "=SUBTOTAL(9,G5:G" & LastRow3 & ")"
    wsC.Range("G" & LastRow3 + 2).Font.bold = True
    wsC.Range("H" & LastRow3 + 2).Formula = "=SUBTOTAL(9,H5:H" & LastRow3 & ")"
    wsC.Range("H" & LastRow3 + 2).Font.bold = True
    wsC.Range("G:H").NumberFormat = "#,##0.00_);[Red](#,##0.00)"
    wsC.Range("I4:I" & LastRow3).Replace What:="85175", Replacement:="100085175", LookAt:= _
        xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
    wsC.Columns("A:A").EntireColumn.AutoFit
    wsC.Columns("C:J").EntireColumn.AutoFit
    Application.Goto wsC.Range("A5:A" & LastRow3), True
    wsC.Cells(wsC.Rows.Count, "H").End(xlUp).Select

Open in new window

0
 
LVL 28

Author Comment

by:Shums
ID: 38321377
Hi All,

I thought I reached my goal, but if I change raw data for previous months or longer or shorter, this VBA does unexpected behavior for Subtotal in Sheet CabGoc; , I am attaching sample file and 3 months raw data for your reverence.
Please help.....


Thanking You in advance......
CommCalc-1-.xls
April-2012.txt
May-2012.txt
June-2012.txt
0
 
LVL 28

Author Comment

by:Shums
ID: 38327000
I got it solved.......thanks all for your effort.
0
 
LVL 28

Author Closing Comment

by:Shums
ID: 38340094
I am learning something new everyday, thank you all for your guidance.
0

Featured Post

Industry Leaders: 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

When there is a disconnect between the intentions of their creator and the recipient, when algorithms go awry, they can have disastrous consequences.
This article describes how you can use Custom Document Properties to store settings and other information in your workbook so that they will be available the next time you open the workbook.
This Micro Tutorial will demonstrate the scrolling table in Microsoft Excel using the INDEX function.
This Micro Tutorial will demonstrate how to create pivot charts out of a data set. I also added a drop-down menu which allows to choose from different categories in the data set and the chart will automatically update.

865 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