PDA

View Full Version : Need help combining two sets of code into one sheet



Spike69
08-03-2007, 07:09 AM
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

Spike69
08-03-2007, 07:11 AM
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