Consulting

Results 1 to 2 of 2

Thread: Need help combining two sets of code into one sheet

  1. #1
    VBAX Regular
    Joined
    Jul 2007
    Posts
    20
    Location

    Need help combining two sets of code into one sheet

    This is my primary program......



    Sub Program()

    '
    'Creates Variables to be used in the program
    '
    Dim i, k, j As Integer
    Dim myFile, mypath, Fichiers(1000), NomCompose, UniteCompose, Avg As String
    Dim NbComposes, Lignetravail, InfoTypeNumber, NBFichier, _
    NbResultats, DataRows As Double
    Dim Nomdufichier, nomfichier As String
    Dim File As Object
    Dim R As Long
    Dim C, Rng As Range
    'Dim wks As Workbook

    '
    ' Creates a path to open the DataEchantillon File
    '
    myPath2 = "D:\Documents and Settings\pw41203\Desktop\Eric\Excel_Program\DataEchantillon"
    '
    ' Opens the DataEchantillon file
    '
    Workbooks.Open Filename:=myPath2
    Lignetravail = 2
    '
    'Counts how many .xls files are in the folder called Analyze
    '

    myFile = Dir("C:\conv\Analyze\*.xls")
    mypath = "C:\conv\Analyze\"
    i = 0
    Do While myFile <> ""
    i = i + 1

    Fichiers(i) = myFile
    myFile = Dir
    Loop
    NBFichier = i

    '
    'Creates a for loop in order to open Analyze file(s) and to determine the file name
    '
    For i = 1 To NBFichier
    '
    'Opens Analyze file
    '
    Nomdufichier = mypath & Fichiers(i)
    Workbooks.Open (Nomdufichier)
    nomfichier = Cells(2, 1)

    '
    ' Find how many components are contained through the Range("B3" To "E3") in the Analyze files
    '
    NbComposes = 1

    Do While Cells(1, NbComposes + 2) <> ""
    NbComposes = NbComposes + 1
    Loop
    For j = 1 To Nbcompose
    NomCompose = Cells(1, j + 1)
    UniteCompose = Cells(2, j + 1)
    Next j

    ' Combine les resultats des basses de donner

    For k = 1 To NbResultats

    '
    ' Calculer l' infotype de l' analyse
    '
    InfoTypeNumber = 10000 + nomfichier * 10 + j
    '

    '
    ' Copies the result, and the Dates from Analyze files
    ' Copies values to "DataEchantillon.xls" File
    '
    Lignetravail = Lignetravail + 1

    End If

    Next k
    Next i

    '
    ' Closes the File
    '

    End Sub

  2. #2
    VBAX Regular
    Joined
    Jul 2007
    Posts
    20
    Location
    And this is the code i need inserted at the right places which is indicated with comments as to where things go..


    Sub dataTransfer()

    Dim wkbData As Workbook
    Dim cell As Range
    Dim Fichiers() As String, nomFichier As String, myPath As String, myFile As String
    Dim i As Integer, NBFichier As Integer
    Dim wks As Worksheet
    Dim rngTarget As Range, rngCell As Range
    Dim lngLastRow As Long

    myPath = "C:\conv\Analyze\"
    myFile = Dir(myPath & "*.xls")
    i = 0
    Do While myFile <> ""
    ReDim Preserve Fichiers(i)
    Fichiers(i) = myFile
    i = i + 1
    myFile = Dir
    Loop
    NBFichier = UBound(Fichiers) + 1
    'nomFichier = Cells(2, 1)

    '
    ' Creates a path to open the DataEchantillon File
    '
    myPath2 = "D:\Documents and Settings\pw41203\Desktop\Eric\Excel_Program\DataEchantillon.xls"
    '
    ' Ouvre le fichier DataEchantillon
    '
    Workbooks.Open Filename:=myPath2
    Lignetravail = 2
    '

    Workbooks.Open Filename:=myPath & Fichiers(i), ReadOnly:=True
    nomFichier = Cells(2, 1)
    '
    ' Trouver le nombre de composantes
    '
    NbComposes = 1

    Do While Cells(1, NbComposes + 2) <> ""
    NbComposes = NbComposes + 1
    Loop
    For j = 1 To Nbcompose
    NomCompose = Cells(1, j + 1)
    UniteCompose = Cells(2, j + 1)
    Next j


    Stop

    ' Transfers date values from all open Analysis to the file "DataEchantillon.xls"


    Set rngTarget = Workbooks("DataEchantillon.xls").Worksheets(1).Cells(3, "B")
    For i = LBound(Fichiers) To UBound(Fichiers)
    Set wkbData = Workbooks.Open(Filename:=myPath & Fichiers(i), ReadOnly:=True)
    ' Check sheet exists
    Set wks = wkbData.Worksheets(1)
    lngLastRow = wks.Range("A65536").End(xlUp).Row
    ' make sure there is data in row 3 or below
    If lngLastRow > 2 Then
    For Each rngCell In wks.Range(wks.Range("A3"), wks.Cells(lngLastRow, "A"))
    If Len(Trim$(rngCell.Value)) > 0 Then
    Union(rngTarget, rngTarget.Offset(0, 5)).Value = rngCell.Value
    Set rngTarget = rngTarget.Offset(1, 0)
    End If
    Next rngCell
    End If
    wkbData.Close False
    Next i
    'rngTarget.Parent.Parent.Close True


    ' Transfers data values from Analysis to the file "DataEchantillon.xls"

    Set rngTarget = Workbooks("DataEchantillon.xls").Worksheets(1).Cells(3, "AG")
    For i = LBound(Fichiers) To UBound(Fichiers)
    Set wkbData = Workbooks.Open(Filename:=myPath & Fichiers(i), ReadOnly:=True)
    ' Check sheet exists
    Set wks = wkbData.Worksheets(1)
    lngLastRow = wks.Range("B65536").End(xlUp).Row
    ' make sure there is data in row 3 or below
    If lngLastRow > 2 Then
    For Each rngCell In wks.Range(wks.Range("B3:E3"), wks.Cells(lngLastRow, "AG"))
    If Len(Trim$(rngCell.Value)) > 0 Then
    Union(rngTarget, rngTarget).Value = rngCell.Value
    Set rngTarget = rngTarget.Offset(1, 0)
    End If
    Next rngCell
    End If
    wkbData.Close False
    Next i
    'rngTarget.Parent.Parent.Close True
    End Sub

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •