?
Solved

Simple Excel VBAF

Posted on 2014-04-07
11
1 solution
Medium Priority
?
190 Views
Last Modified: 2014-04-22
Hi Experts,

I have two piece of Code which I have in two different module . I want to run code 2 in code 1.At 2 stages (IF & Else) end. And add few more steps in code 1. 
 If wbData.Sheets(1).Name = wbResult.Sheets(1).Name Then
        wbData.Sheets(1).Range("A1:F" & Range("F1048576").End(xlUp).Row).Copy
        wbCurrent.Activate
        Range("A1").PasteSpecial

        wbResult.Activate
        wbResult.Sheets(1).Range("A3:C3").Copy
        wbCurrent.Activate
        Range("L3:N3").PasteSpecial

Open in new window

Above code Copy data from other sheet & past to Current WB - I want add few things after @ if end
Copied data sort in oldest to newest date wise (Column A)
Run Sub FindValues() (Module – “ZigZag”)  
Copy L3:W end row except last row & past to related sheet. But after shift row down data which is exist in sheet from A3.
& Clear Data (A1:F end row, L4:W till end, L3:N3)
Else
        wbData.Sheets(1).Range("A1:F" & Range("F1048576").End(xlUp).Row).Copy
        wbCurrent.Activate
        Range("A1").PasteSpecial

        If IsArrayAllocated(arrSheetName) Then
            i = 0
            wbResult.Activate
            For i = LBound(arrSheetName) To UBound(arrSheetName) - 1
                If i + 1 > wbResult.Sheets("Finish").Index - 1 Then Exit For
                varData = Split(InputBox("Please enter value for L3:N3 in sheet " & wbResult.Sheets(arrSheetName(i + 1)).Name & ", seperated by a space.", "Data input"), " ")
                wbResult.Sheets(arrSheetName(i + 1)).Range("L3").Value = varData(0)
                wbResult.Sheets(arrSheetName(i + 1)).Range("M3").Value = varData(1)
                wbResult.Sheets(arrSheetName(i + 1)).Range("N3").Value = varData(2)

Open in new window

& in above code sheet name doesn’t found & it is else statement.
It copies data from Data WB & put manually L3:N3 values via input box. I want in this flow.
I want  on copied data sort oldest to newest date wise (Column A)
Manual entry of range L3:N3 via input box
Run Sub FindValues() (Module – “ZigZag”)  
Copy data L1:W till end & past to new created sheet A1.
& Clear Data (A1:F end row, L4:W till end, L3:N3)

This is whole Code 
Option Explicit

Sub Demo()

    Dim wbCurrent As Workbook, wbData As Workbook, wbResult As Workbook
    Dim ws As Worksheet, w As Worksheet
    Dim varData() As String
    Dim arrSheetName() As String
    Dim i As Integer
    Dim blnExists As Boolean

    Set wbCurrent = ActiveWorkbook
    Set wbData = Workbooks.Open(ActiveWorkbook.Path & "\Data.xlsx")    '("H:\4.Trading Master\Thunderbolt\Simple Excel Formula\Data.xlsx")

    wbData.Activate
    SortWorksheets

    Set wbResult = Workbooks.Open(ActiveWorkbook.Path & "\Result.xlsx")    '("H:\4.Trading Master\Thunderbolt\Simple Excel Formula\Result.xlsx")

    wbResult.Activate
    SortWorksheets

    For Each ws In wbData.Worksheets
        If ws.Index > wbData.Sheets("Start").Index And ws.Index < wbData.Sheets("Finish").Index Then
            If (wbResult.Sheets(ws.Index).Name <> ws.Name) Or (ws.Index > Sheets(Sheets.Count).Index - 1) Then
                For Each w In wbResult.Worksheets
                    If w.Name = ws.Name Then blnExists = True
                Next
                If Not blnExists Then
                    wbResult.Sheets.Add.Name = ws.Name
                    i = i + 1
                    ReDim Preserve arrSheetName(0 To i)
                    arrSheetName(i) = ws.Name
                End If
            End If
        End If
    Next

    wbData.Activate

    If wbData.Sheets(1).Name = wbResult.Sheets(1).Name Then
        wbData.Sheets(1).Range("A1:F" & Range("F1048576").End(xlUp).Row).Copy
        wbCurrent.Activate
        Range("A1").PasteSpecial

        wbResult.Activate
        wbResult.Sheets(1).Range("A3:C3").Copy
        wbCurrent.Activate
        Range("L3:N3").PasteSpecial
    Else
        wbData.Sheets(1).Range("A1:F" & Range("F1048576").End(xlUp).Row).Copy
        wbCurrent.Activate
        Range("A1").PasteSpecial

        If IsArrayAllocated(arrSheetName) Then
            i = 0
            wbResult.Activate
            For i = LBound(arrSheetName) To UBound(arrSheetName) - 1
                If i + 1 > wbResult.Sheets("Finish").Index - 1 Then Exit For
                varData = Split(InputBox("Please enter value for L3:N3 in sheet " & wbResult.Sheets(arrSheetName(i + 1)).Name & ", seperated by a space.", "Data input"), " ")
                wbResult.Sheets(arrSheetName(i + 1)).Range("L3").Value = varData(0)
                wbResult.Sheets(arrSheetName(i + 1)).Range("M3").Value = varData(1)
                wbResult.Sheets(arrSheetName(i + 1)).Range("N3").Value = varData(2)
            Next
        End If

    End If

    wbData.Activate
    SortWorksheets
    wbResult.Activate
    SortWorksheets

    wbData.Close True
    wbResult.Close True

End Sub

Private Sub SortWorksheets()

    Dim N As Integer
    Dim M As Integer
    Dim FirstWSToSort As Integer
    Dim LastWSToSort As Integer
    Dim SortDescending As Boolean

    SortDescending = False

    If ActiveWindow.SelectedSheets.Count = 1 Then
        FirstWSToSort = Worksheets("Start").Index + 1
        LastWSToSort = Worksheets("Finish").Index - 1
    Else
        With ActiveWindow.SelectedSheets
            For N = 2 To .Count
                If .Item(N - 1).Index <> .Item(N).Index - 1 Then
                    MsgBox "You cannot sort non-adjacent sheets"
                    Exit Sub
                End If
            Next N
            FirstWSToSort = .Item(1).Index
            LastWSToSort = .Item(.Count).Index
        End With
    End If

    For M = FirstWSToSort To LastWSToSort
        For N = M To LastWSToSort
            If SortDescending = True Then
                If UCase(Worksheets(N).Name) > UCase(Worksheets(M).Name) Then
                    Worksheets(N).Move Before:=Worksheets(M)
                End If
            Else
                If UCase(Worksheets(N).Name) < UCase(Worksheets(M).Name) Then
                    Worksheets(N).Move Before:=Worksheets(M)
                End If
            End If
        Next N
    Next M

End Sub

Function IsArrayAllocated(Arr As Variant) As Boolean
    On Error Resume Next
    IsArrayAllocated = IsArray(Arr) And _
                       Not IsError(LBound(Arr, 1)) And _
                       LBound(Arr, 1) <= UBound(Arr, 1)
End Function

Open in new window


Thanks & Any confusion revert me back. Sun FindValues is in attached WB Process.
Data.xlsm
Process.xlsm
Result.xlsm
0
Comment
Question by:Naresh Patel
  • 7
  • 4
11 Comments
 
LVL 28

Accepted Solution

by:
MacroShadow earned 2000 total points
ID: 39982887
Somethings I understand and some I don't.

Copied data sort in oldest to newest date wise (Column A)
I want  on copied data sort oldest to newest date wise (Column A)
You only copy 3 adjacent cells, I'm not sure what data you want sorted.

Copy L3:W end row except last row & past to related sheet.
Please name workbook and worksheets.

But after shift row down data which is exist in sheet from A3.
Not sure what you mean, please explain in simple English.

Manual entry of range L3:N3 via input box
You have that already

Run Sub FindValues() (Module – “ZigZag”)
Since you want this code to run in both cases (if and else) add call findvalues after end if

Copy data L1:W till end & past to new created sheet A1.
Copy from which sheet and paste to which sheet?

& Clear Data (A1:F end row, L4:W till end, L3:N3)
You just pasted it, why clear it, if want to clear it don't paste it.
0
 
LVL 8

Author Comment

by:Naresh Patel
ID: 39983080
In Both cases IF & Else it copies data from Data WB to Process WB .

Date in Data WB is  Newest to oldest so if we copy & past to Process WB it will remain same way but for Sub FindValues() it required Date in Oldest to newest. so sort date which is in column A oldest to newest.

Before SortAfter Sort
Copy L3:W end row except last row & past to related sheet.
But after shift row down data which is exist in sheet from A3.
Basically I am finding high & low points from data of Open high low Close of stock price. so to find this high Low point (Zigzag points at least one High or low point required in range L3:N3,you can say it start point). Formula & code is set in that manner after that it will find next high low point & its date of occurrence. so if data WB & Result WB have same name sheet then that name operation is done in past, so we need last point for that name from result WB & pasted to Process for find further points. After process we have more points including the point which we copied from result WB so in copy past task need to exclude that as it is already in result WB. But in case of Data WB & Result WB name not match then we have to put manually that L3:N3 point as there is not any past exploration.

IF Match FoundIF Match Not Found
Please 1st understand then write Code else it will leads to trial & error. need further clarification pls let me know.

Thanks
0
 
LVL 28

Expert Comment

by:MacroShadow
ID: 39983306
How about sample files with data resembling the real data. It's a total waste of my time to try to figure out exactly what you want with the data I have!
0
Upgrade your Question Security!

Your question, your audience. Choose who sees your identity—and your question—with question security.

Go Premium
 
LVL 8

Author Comment

by:Naresh Patel
ID: 39983331
I give you full description with screen shots just tell me which part you dint understand?
0
 
LVL 8

Author Comment

by:Naresh Patel
ID: 39983392
let first explain what mi achieving by this. I want High  Low point of stock price. for that I have Code Sub FindValue().which do calculation & & find high low points from data provided. There is two types of data require for this exploration. historical data (Column A:F) & last point (L3:N3).

so 1st kind of data we can get it from Data WB (A:F) but 2nd type of data we can get two ways. A) if in past we done this exploration then we can copy last points from result WB (A3:C3) 2) but if we add new sheet in data WB then there is not match found in Result WB & we have to put manually 2nd type of data via input message box.

Note :- In Data WB data will be added every day for each sheet name.

Thanks
0
 
LVL 8

Author Comment

by:Naresh Patel
ID: 39985657 
Sub Demo()

    Dim wbCurrent, wbData, wbResult As Workbook
    Dim ws, w As Worksheet
    Dim varData() As String
    Dim arrSheetName() As String
    Dim i As Integer
    Dim blnExists As Boolean

    Set wbCurrent = ActiveWorkbook
    Set wbData = Workbooks.Open(ActiveWorkbook.Path & "\Data.xlsx")    '("H:\4.Trading Master\Thunderbolt\Simple Excel Formula\Data.xlsx")

    wbData.Activate
    SortWorksheets

    Set wbResult = Workbooks.Open(ActiveWorkbook.Path & "\Result.xlsx")    '("H:\4.Trading Master\Thunderbolt\Simple Excel Formula\Result.xlsx")

    wbResult.Activate
    SortWorksheets

    For Each ws In wbData.Worksheets
        If ws.Index > wbData.Sheets("Start").Index And ws.Index < wbData.Sheets("Finish").Index Then
            If (wbResult.Sheets(ws.Index).Name <> ws.Name) Or (ws.Index > Sheets(Sheets.Count).Index - 1) Then
                For Each w In wbResult.Worksheets
                    If w.Name = ws.Name Then blnExists = True
                Next
                If Not blnExists Then
                    wbResult.Sheets.Add.Name = ws.Name
                    i = i + 1
                    ReDim Preserve arrSheetName(0 To i)
                    arrSheetName(i) = ws.Name
                End If
            End If
        End If
    Next

    wbData.Activate

    If wbData.Sheets(1).Name = wbResult.Sheets(1).Name Then
        wbData.Sheets(1).Range("A1:F" & Range("F1048576").End(xlUp).Row).Copy
        wbCurrent.Activate
        Range("A1").PasteSpecial
        SortData
        
        wbResult.Activate
        wbResult.Sheets(1).Range("A3:C3").Copy
        wbCurrent.Activate
        Range("L3:N3").PasteSpecial
        FindValues
        .Range("N3:W" & Range("W1048576").End(xlUp).Row).Offset(-1, 0).Copy
        wbResult.Activate
        wbResult.Sheets(1).Range("A3").Insert Shift:=xlDown
        
        wbCurrent.Activate
        .Range("L3:N3").ClearContents
        .Range("A1:F" & Range("F1048576").End(xlUp).Row).ClearContents
        .Range("N3:W" & Range("F1048576").End(xlUp).Row).ClearContents

Open in new window


I had added some line via online searching for IF Match found statement but it flashes errorErrorI had added this Sub for Sorting 
Sub SortData()

 Dim oneRange As Range
 Dim aCell As Range
 Set oneRange = Range("A3:F" & Range("F1048576").End(xlUp).Row)
 Set aCell = Range("A3")
 oneRange.Sort Key1:=aCell, Order1:=xlAscending, Header:=xlNo

 End Sub

Open in new window


Thanks
Process.xlsm
0
 
LVL 28

Expert Comment

by:MacroShadow
ID: 39985662
remove the period before range
0
 
LVL 8

Author Comment

by:Naresh Patel
ID: 39985682
Period...?
0
 
LVL 28

Expert Comment

by:MacroShadow
ID: 39985686
change
.Range("N3:W" & Range("W1048576").End(xlUp).Row).Offset(-1, 0).Copy
to
Range("N3:W" & Range("W1048576").End(xlUp).Row).Offset(-1, 0).Copy
0
 
LVL 8

Author Comment

by:Naresh Patel
ID: 39985793
Working - No error
But In data WB & Result WB I had make both sheet remain same between sheet Start - finish i.e. there is only 2 sheets in both WB with same name so no need to go for ELSE Code part to run..... only Match part to run but it is not working ...? any idea ? I had run through code step by step (F8) but it not executing IF Match found lines ....where mi wrong.?

This is the whole code 
Option Explicit

Sub Demo()

    Dim wbCurrent, wbData, wbResult As Workbook
    Dim ws, w As Worksheet
    Dim varData() As String
    Dim arrSheetName() As String
    Dim i As Integer
    Dim blnExists As Boolean

    Set wbCurrent = ActiveWorkbook
    Set wbData = Workbooks.Open(ActiveWorkbook.Path & "\Data.xlsm")    '("H:\4.Trading Master\Thunderbolt\Simple Excel Formula\Data.xlsx")

    wbData.Activate
    SortWorksheets

    Set wbResult = Workbooks.Open(ActiveWorkbook.Path & "\Result.xlsm")    '("H:\4.Trading Master\Thunderbolt\Simple Excel Formula\Result.xlsx")

    wbResult.Activate
    SortWorksheets

    For Each ws In wbData.Worksheets
        If ws.Index > wbData.Sheets("Start").Index And ws.Index < wbData.Sheets("Finish").Index Then
            If (wbResult.Sheets(ws.Index).Name <> ws.Name) Or (ws.Index > Sheets(Sheets.Count).Index - 1) Then
                For Each w In wbResult.Worksheets
                    If w.Name = ws.Name Then blnExists = True
                Next
                If Not blnExists Then
                    wbResult.Sheets.Add.Name = ws.Name
                    i = i + 1
                    ReDim Preserve arrSheetName(0 To i)
                    arrSheetName(i) = ws.Name
                End If
            End If
        End If
    Next

    wbData.Activate

    If wbData.Sheets(1).Name = wbResult.Sheets(1).Name Then
        wbData.Sheets(1).Range("A1:F" & Range("F1048576").End(xlUp).Row).Copy
        wbCurrent.Activate
        Range("A1").PasteSpecial
        SortData
        
        wbResult.Activate
        wbResult.Sheets(1).Range("A3:C3").Copy
        wbCurrent.Activate
        Range("L3:N3").PasteSpecial
        FindValues
        Range("N3:W" & Range("W1048576").End(xlUp).Row).Offset(-1, 0).Copy
        wbResult.Activate
        wbResult.Sheets(1).Range("A3").Insert Shift:=xlDown
        
        wbCurrent.Activate
        Range("L3:N3").ClearContents
        Range("A1:F" & Range("F1048576").End(xlUp).Row).ClearContents
        Range("L4:W" & Range("F1048576").End(xlUp).Row).ClearContents

        
    Else
        wbData.Sheets(1).Range("A1:F" & Range("F1048576").End(xlUp).Row).Copy
        wbCurrent.Activate
        Range("A1").PasteSpecial
        SortData
        If IsArrayAllocated(arrSheetName) Then
            i = 0
            wbResult.Activate
            For i = LBound(arrSheetName) To UBound(arrSheetName) - 1
                If i + 1 > wbResult.Sheets("Finish").Index - 1 Then Exit For
                varData = Split(InputBox("Please enter value for L3:N3 in sheet " & wbResult.Sheets(arrSheetName(i + 1)).Name & ", seperated by a space.", "Data input"), " ")
                wbResult.Sheets(arrSheetName(i + 1)).Range("L3").Value = varData(0)
                wbResult.Sheets(arrSheetName(i + 1)).Range("M3").Value = varData(1)
                wbResult.Sheets(arrSheetName(i + 1)).Range("N3").Value = varData(2)
            Next
        End If

    End If

    wbData.Activate
    SortWorksheets
    wbResult.Activate
    SortWorksheets

    wbData.Close True
    wbResult.Close True

End Sub

Private Sub SortWorksheets()

    Dim N As Integer
    Dim M As Integer
    Dim FirstWSToSort As Integer
    Dim LastWSToSort As Integer
    Dim SortDescending As Boolean

    SortDescending = False

    If ActiveWindow.SelectedSheets.Count = 1 Then
        FirstWSToSort = Worksheets("Start").Index + 1
        LastWSToSort = Worksheets("Finish").Index - 1
    Else
        With ActiveWindow.SelectedSheets
            For N = 2 To .Count
                If .Item(N - 1).Index <> .Item(N).Index - 1 Then
                    MsgBox "You cannot sort non-adjacent sheets"
                    Exit Sub
                End If
            Next N
            FirstWSToSort = .Item(1).Index
            LastWSToSort = .Item(.Count).Index
        End With
    End If

    For M = FirstWSToSort To LastWSToSort
        For N = M To LastWSToSort
            If SortDescending = True Then
                If UCase(Worksheets(N).Name) > UCase(Worksheets(M).Name) Then
                    Worksheets(N).Move Before:=Worksheets(M)
                End If
            Else
                If UCase(Worksheets(N).Name) < UCase(Worksheets(M).Name) Then
                    Worksheets(N).Move Before:=Worksheets(M)
                End If
            End If
        Next N
    Next M

End Sub

Function IsArrayAllocated(Arr As Variant) As Boolean
    On Error Resume Next
    IsArrayAllocated = IsArray(Arr) And _
                       Not IsError(LBound(Arr, 1)) And _
                       LBound(Arr, 1) <= UBound(Arr, 1)
End Function

Sub SortData()

 Dim oneRange As Range
 Dim aCell As Range
 Set oneRange = Range("A3:F" & Range("F1048576").End(xlUp).Row)
 Set aCell = Range("A3")
 oneRange.Sort Key1:=aCell, Order1:=xlAscending, Header:=xlNo

 End Sub

Open in new window


Thanks
0
 
LVL 8

Author Comment

by:Naresh Patel
ID: 39985841
Did you got it what mi trying to achieve? I had added Sub SortData & Sub FindValues in between code which you have provided . & set WB as only match condition is founds. but I am getting no result.

Thanks
Data.xlsm
Process.xlsm
Result.xlsm
0

Featured Post

Free Tool: Site Down Detector

Helpful to verify reports of your own downtime, or to double check a downed website you are trying to access.

One of a set of tools we are providing to everyone as a way of saying thank you for being a part of the community.

Access It Now
Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.

Join & Write a Comment

Create a new Microsoft Account User Profile in Windows 10
Article by: Andrew
This tutorial is about creating a new Microsoft Online User Profile account along with how to transfer your files and settings. You may be faced with this situation if your existing user profile has become corrupted.
Convert and format imperial distance (feet and inches) with high precision
Article by: Gustav
With the functions here, you can parse, convert, and format back and forth between feet and inches and fractions and decimal inches - for normal as well as extreme values and with extreme precision.
How to Create Paragraph Styles in Word
Video by: Leslie
Learn how to create and modify your own paragraph styles in Microsoft Word. This can be helpful when wanting to make consistently referenced styles throughout a document or template.
How To Insert Foreign and Special Characters when in Windows Applications
Video by: crystal
Enter Foreign and Special Characters Enter characters you can't find on a keyboard using its ASCII code ... and learn how to make a handy reference for yourself using Excel ~ Use these codes in any Windows application! ... whether it is a Micr…
Advertise Here

569 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

Advertise Here