PDA

View Full Version : [Help] Exporting data and filling columns



Acen
10-29-2012, 07:10 PM
Hello.
First things first, VBA is the hardest language to learn I've ever had the pleasure? of working with.
Straight, easy to follow documentation seems to be impossible to find.
Anyway --

What I'm trying to do:
Copy data from one spreadsheet (or worksheet) to another two spreadsheets (/worksheets) and rearrange the columns differently on both exported spreadsheets. Then, filling in certain columns on the outgoing spreadsheets with specified data.

I've never used VBA before, however it's pretty necessary for me to learn - so here I go.

This is what I have.
It rearranges the data as per contactimport.csv and enroleimport.csv

Sub Macro1()
'
' Macro1 Macro
'

Set objExcel = CreateObject("Excel.Application")
objExcel.Visible = True
Dim objWorkbook As Workbook
Set objWorkbook = objExcel.Workbooks.Open("C:\input.xlsx")
objWorkbook.Sheets(1).Activate
objWorkbook.Worksheets.Add
objWorkbook.Sheets(2).Activate

Dim F As Long, fromRange As String, toRange As String
F = FreeFile
Open "C:\contactimport.csv" For Input As F
While Not EOF(F)
Input #F, fromRange, toRange

Set objWorksheet = objWorkbook.Worksheets(2)
objWorksheet.Activate

objWorkbook.Sheets(2).Range(fromRange).EntireColumn.Copy

Set objWorksheet = objWorkbook.Worksheets(1)
objWorksheet.Activate

Set objRange = objWorkbook.Sheets(1).Range(toRange)
objWorksheet.Paste (objRange)

Wend
Close F

objWorkbook.Worksheets.Add

Open "C:\enroleimport.csv" For Input As F
While Not EOF(F)
Input #F, fromRange, toRange

Set objWorksheet = objWorkbook.Worksheets(3)
objWorksheet.Activate

objWorkbook.Sheets(3).Range(fromRange).EntireColumn.Copy

Set objWorksheet = objWorkbook.Worksheets(1)
objWorksheet.Activate

Set objRange = objWorkbook.Sheets(1).Range(toRange)
objWorksheet.Paste (objRange)

Wend
Close F

End Sub


input.xlsx
See attachment. Filled with a row of test data.

contactimport.csv


B1,E1
C1,D1
D1,F1
E1,Q1
F1,AO1
G1,AP1
H1,AR1
I1,AS1
J1,AT1
K1,AU1
L1,AW1
M1,AX1
N1,AZ1
O1,BA1
P1,BB1
Q1,BC1
R1,BD1
S1,BE1
T1,BO1
W1,M1
X1,V1
AE1,T1
AG1,S1
AH1,G1
AI1,AA1
AJ1,J1

enroleimport.csv


AB1,L1
AC1,M1
AL1,R1
AM1,S1
AN1,T1
AF1,X1
Z1,AH1


So now, what I need it to do, is add another one or two simple CSV files with the same sort of layout (for simplicity later on).
Say like


A2,cluster
D2,banana

Would have column A2, below A1 to leave the name, filled with "cluster" down every row.
The same with D2. Every row in D apart from 1, filled with the value "banana".

So, help please?

Also any suggestions on what I have so far would be much appreciated.


Notepad for progress:


Dim Populate As Long, columnChoice As String, columnData As String
Populate = FreeFile
Open "C:\populatedatacontact.csv" For Input As Populate
While Not EOF(Populate)
Input #Populate, columnChoice, columnData
Set objWorksheet = objWorkbook.Worksheets(2)
objWorksheet.Activate
Wend
Close Populate

Acen
10-30-2012, 01:14 PM
Update: Attempting to clean code.


' todo:
' Function/private function (sub) everything
' Name worksheets properly
'
'
'
'
Sub Macro1()

' BASE
Set objExcel = CreateObject("Excel.Application")
objExcel.Visible = True
Dim objWorkbook As Workbook
Set objWorkbook = objExcel.Workbooks.Open("C:\input.xlsx")
objWorkbook.Sheets(1).Activate
Set ActiveSheet.Name = "input"


' Create then name worksheets
Function CreateSheets()
objWorkbook.Worksheets.Add (After:=Worksheets(Worksheets.Count)).Name = "contactexport"
objWorkbook.Worksheets.Add (After:=Worksheets(Worksheets.Count)).Name = "enrolexport"
End Function

' contactimport
Function ContactImport(F As Long, fromRange As Range, toRange As Range)
F = FreeFile
Open "C:\contactimport.csv" For Input As F
While Not EOF(F)
Input #F, fromRange, toRange
Set objWorksheet = objWorkbook.Worksheets("input")
objWorksheet.Activate
objWorkbook.ActiveSheet.fromRange.EntireColumn.Copy
Set objWorksheet = objWorkbook.Worksheets("contactexport")
objWorksheet.Activate
Set objRange = objWorkbook.ActiveSheet.toRange
objWorksheet.Paste (objRange)
Wend
Close F
End Function

' enrolimport
Function EnrolImport(F As Long, fromRange As Range, toRange As Range)
F = FreeFile
Open "C:\enrolimport.csv" For Input As F
While Not EOF(F)
Input #F, fromRange, toRange
Set objWorksheet = objWorkbook.Worksheets("input")
objWorksheet.Activate
objWorkbook.ActiveSheet.fromRange.EntireColumn.Copy
Set objWorksheet = objWorkbook.Worksheets("enrolexport")
objWorksheet.Activate
Set objRange = objWorkbook.ActiveSheet.toRange
objWorksheet.Paste (objRange)
Wend
Close F
End Function


' Populate fields (under construction)
' Function PopulateFields(Populate As Long, columnChoice As Range, columnData As String)
'' Populate = FreeFile
' Open "C:\populatedatacontact.csv" For Input As Populate
' While Not EOF(Populate)
' Input #Populate, columnChoice, columnData
' Set objWorksheet = objWorkbook.Worksheets(2)
' objWorksheet.Activate
' Wend
' Close Populate
' End Function

End Sub

p45cal
10-30-2012, 03:27 PM
try:Sub blah()
Dim objWorkbook As Workbook
Dim F As Long, fromRange As String, toRange As String

Set objWorkbook = Workbooks.Open("C:\input.xlsx")
With objWorkbook
Set InputSht = .Worksheets(1)
InputSht.Name = "input"
Set contactexportSht = .Worksheets.Add(after:=.Worksheets(.Worksheets.Count))
contactexportSht.Name = "contactexport"
Set enrolexportSht = .Worksheets.Add(after:=.Worksheets(.Worksheets.Count))
enrolexportSht.Name = "enrolexport"
End With

F = FreeFile
Open "C:\contactimport.csv" For Input As F
While Not EOF(F)
Input #F, fromRange, toRange
InputSht.Range(fromRange).EntireColumn.Copy contactexportSht.Range(toRange)
Wend
Close F

F = FreeFile
Open "C:\enroleimport.csv" For Input As F
While Not EOF(F)
Input #F, fromRange, toRange
InputSht.Range(fromRange).EntireColumn.Copy enrolexportSht.Range(toRange)
Wend
Close F
End Sub

Acen
10-30-2012, 03:40 PM
That works really quickly!
Thank you.

Teeroy
10-31-2012, 12:28 AM
Hi Acen,

VBA's not that bad, I remember having to learn C and FORTAN at uni <shudder>. Since you're learning VBA now I would look at changing the while / wends to Do loops. While / wends have been around since GW Basic but are not commonly used now; they are generally for backward compatibility.

Acen
10-31-2012, 12:19 PM
That's good to know, thank you.

Am working on a userform version now.
Replaced While Not / Wend with Do / Loop Until

Private Function blah()
Dim objWorkbook As Workbook
Dim objContactHeader As Workbook
Dim F As Long, fromRange As String, toRange As String

Set objWorkbook = Workbooks.Open(UserForm1.TextBox1.Value)
With objWorkbook
Set Inputsht = .Worksheets(1)
Inputsht.Name = "input"
Set contactexportSht = .Worksheets.Add(after:=.Worksheets(.Worksheets.Count))
contactexportSht.Name = "contactexport"
Set enrolexportSht = .Worksheets.Add(after:=.Worksheets(.Worksheets.Count))
enrolexportSht.Name = "enrolexport"
End With

F = FreeFile
Open "C:\contactimport.csv" For Input As F
Do
Input #F, fromRange, toRange
Inputsht.Range(fromRange).EntireColumn.Copy contactexportSht.Range(toRange)
Loop Until EOF(F)
Close F

Set objContactHeader = Workbooks.Open("C:\contactheaders.xlsx")
objContactHeader.Worksheets(1).Range("A1").EntireRow.Copy contactexportSht.Range("A1")
objContactHeader.Close

F = FreeFile
Open "C:\enroleimport.csv" For Input As F
Do
Input #F, fromRange, toRange
Inputsht.Range(fromRange).EntireColumn.Copy enrolexportSht.Range(toRange)
Loop Until EOF(F)
Close F
End Function


Private Sub run_Click()
blah
Unload Me
End Sub

Friend Sub selectInput_Click()
Dim MyPath As String
MyPath = Application _
.GetOpenFilename("Excel (*.xlsx), *.xlsx")
If Len(MyPath) Then
TextBox1.Value = (MyPath)
Else
MsgBox "Cancel was pressed"
End If
End Sub
Would it be appropriate to move the
Input #F, fromRange, toRange
above the Do commands?

Edit: uh, perhaps not.
I think I just crashed it..?

Acen
10-31-2012, 02:33 PM
Here's more progress.


Private Function blah()
Dim objWorkbook As Workbook
Dim objContactHeader As Workbook
Dim F As Long, fromRange As String, toRange As String

' Set
Set objWorkbook = Workbooks.Open(UserForm1.TextBox1.Value)
With objWorkbook
Set Inputsht = .Worksheets(1)
Inputsht.Name = "input"
Set contactexportSht = .Worksheets.Add(after:=.Worksheets(.Worksheets.Count))
contactexportSht.Name = "contactexport"
Set enrolexportSht = .Worksheets.Add(after:=.Worksheets(.Worksheets.Count))
enrolexportSht.Name = "enrolexport"
End With

F = FreeFile
FolderSelect = UserForm1.TextBox3.Value & "contactimport.csv"
Open FolderSelect For Input As F
Do
Input #F, fromRange, toRange
Inputsht.Range(fromRange).EntireColumn.Copy contactexportSht.Range(toRange)
Loop Until EOF(F)
Close F

FolderSelect = UserForm1.TextBox3.Value & "contactheaders.xlsx"
Set objContactHeader = Workbooks.Open(FolderSelect)
objContactHeader.Worksheets(1).Range("A1").EntireRow.Copy contactexportSht.Range("A1")
objContactHeader.Close

F = FreeFile
FolderSelect = UserForm1.TextBox3.Value & "enrolimport.csv"
Open FolderSelect For Input As F
Do
Input #F, fromRange, toRange
Inputsht.Range(fromRange).EntireColumn.Copy enrolexportSht.Range(toRange)
Loop Until EOF(F)
Close F
End Function

Friend Sub selectInput_Click()
Dim MyPath As String
MyPath = Application _
.GetOpenFilename("Excel (*.xlsx), *.xlsx")
If Len(MyPath) Then
TextBox1.Value = (MyPath)
Else
MsgBox "Cancel was pressed"
End If
End Sub

Friend Sub selectInputFolder_Click()
Dim OpenAt As Variant
Dim ShellApp As Object
Dim BrowseForInputFolder As String
Set ShellApp = CreateObject("Shell.Application"). _
BrowseForFolder(0, "Please choose a folder", 0, "C:\")
On Error Resume Next
BrowseForInputFolder = ShellApp.self.Path
TextBox3.Value = (BrowseForInputFolder)
On Error GoTo 0
Set ShellApp = Nothing
Select Case Mid(BrowseForInputFolder, 2, 1)
Case Is = ":"
If Left(BrowseForInputFolder, 1) = ":" Then GoTo Invalid
Case Is = "\"
If Not Left(BrowseForInputFolder, 1) = "\" Then GoTo Invalid
Case Else
GoTo Invalid
End Select
Invalid:
BrowseForInputFolder = False
End Sub

Friend Sub SelectOutput_Click()
Dim OpenAt As Variant
Dim ShellApp As Object
Set ShellApp = CreateObject("Shell.Application"). _
BrowseForFolder(0, "Please choose a folder", 0, "C:\")
On Error Resume Next
BrowseForOutputFolder = ShellApp.self.Path
TextBox2.Value = (BrowseForOutputFolder)
On Error GoTo 0
Set ShellApp = Nothing
Select Case Mid(BrowseForOutputFolder, 2, 1)
Case Is = ":"
If Left(BrowseForOutputFolder, 1) = ":" Then GoTo Invalid
Case Is = "\"
If Not Left(BrowseForOutputFolder, 1) = "\" Then GoTo Invalid
Case Else
GoTo Invalid
End Select
Invalid:
BrowseForOutputFolder = False
End Sub



' Run Button
Private Sub run_Click()
blah
Unload Me
End Sub