Reply
 
LinkBack Thread Tools Search this Thread Display Modes
  #1   Report Post  
Posted to microsoft.public.excel.programming
external usenet poster
 
Posts: 21
Default File Size Problem

Forgive the double posting, I think my last post may have been too poorly
written to be replied to. This time I have pasted the part of the code that
I believe may be the culprit 1st, and then the entire procedures below. The
code below has been causing my xl file to increase by 200kb each time its
run.

This part of the procedure below is where most of the data is written to the
workbook. I'm guessing I am doing something wrong here. (These two
procedures together prompt for file, and then transfer data from the file
provided by the user, into the workbook. Initially the data is simply
copied and pasted into the workbook from the source file, transfered into
arrays, and is then matched up to the correct rows/columns by using a loop
with the match function. ) There are three arrays. x() contains the item
numbers to match, y() and z() are the data to transfer. Thanks in advance.

Possible bad code...?

With ActiveSheet
intcolumn2 = intColumn
Select Case intcolumn2
Case 1
If y(i, 1) < "" Then
.Cells(intPos, 41) = y(i, 1)
End If
If z(i, 1) < "" Then
.Cells(intPos, 42) = z(i, 1)
End If

Full version of code below.....

Sub Import_Prices()
Dim strFile As String
Dim wbThisBook As Workbook
Set wbThisBook = ThisWorkbook
Dim StrBook As String
Dim w As Workbook
Dim strWarning As String
Dim strWarning2 As String
intcolumn2 = 0

strWarning = "Warning, continuing with this step will SAVE and CLOSE all
other open Air Container"
strWarning = strWarning & " workbooks." & vbCrLf & "Click YES if you would
like to continue, click NO if you would "
strWarning = strWarning & "like to close your open Air Container" & vbCrLf &
"workbooks manually." & vbCrLf & vbCrLf
strWarning = strWarning & "
Continue ???"
strWarning2 = "The file you have chosen does not appear to be an Air
Container "
strWarning2 = strWarning2 & vbCrLf & "workbook. Are you sure you want to
import "
strWarning2 = strWarning2 & vbCrLf & "pricing from this file?"
If MsgBox(strWarning, vbYesNo) = vbYes Then

For Each w In Application.Workbooks
StrBook = w.Name
If StrBook & "\" & Workbooks(StrBook).Path = StrBook & "\" &
wbThisBook.Path Then
Else
If InStr(StrBook, "Air Container") = 0 Then
Else
w.Close SaveChanges:=True
End If
End If
Next w

Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
Application.DisplayAlerts = False
'Get file from user and assign to variable
strFile = Application.GetOpenFilename(, , "Select the File to Import Pricing
From")
If strFile < "False" Then
If InStr(strFile, "Air Container") = 0 Then
If MsgBox(strWarning2, vbYesNo + vbCritical, "Warning, possible
incorrect file type!") = vbNo Then Exit Sub
End If
Set wbSource = Workbooks.Open(strFile)
'Copy Data from source book
'Loop through each range
wbSource.Activate
Sheets(2).Activate
Range("AO1:DZ1").Copy
wbThisBook.Activate
Sheets(2).Activate
Range("AO1").Select
ActiveSheet.Paste

Call ShowProgress

For intColumn = 1 To 16
PercentDone = (intColumn + intcolumn2) / 32
Call UpdateProgress(PercentDone)
wbSource.Activate
Sheets(2).Activate
If intColumn = 2 Then
If Len(strMsg) 141 Then
MsgBox strMsg, vbOKOnly
End If
End If
Select Case intColumn
Case 1
Range("A3:A450,AO3:AO450,AP3:AP450").Copy
Case 2
Range("A3:A450,AU3:AU450,AV3:AV450").Copy
Case 3
Range("A3:A450,BA3:BA450,BB3:BB450").Copy
Case 4
Range("A3:A450,BG3:BG450,BH3:BH450").Copy
Case 5
Range("A3:A450,BM3:BM450,BN3:BN450").Copy
Case 6
Range("A3:A450,BS3:BS450,BT3:BT450").Copy
Case 7
Range("A3:A450,BY3:BY450,BZ3:BZ450").Copy
Case 8
Range("A3:A450,CE3:CE450,CF3:CF450").Copy
Case 9
Range("A3:A450,CK3:CK450,CL3:CL450").Copy
Case 10
Range("A3:A450,CQ3:CQ450,CR3:CR450").Copy
Case 11
Range("A3:A450,CW3:CW450,CX3:CX450").Copy
Case 12
Range("A3:A450,DC3:DC450,DD3:DD450").Copy
Case 13
Range("A3:A450,DI3:DI450,DJ3:DJ450").Copy
Case 14
Range("A3:A450,DO3:DO450,DP3:DP450").Copy
Case 15
Range("A3:A450,DU3:DU450,DV3:DV450").Copy
Case 16
Range("A3:A450,AM3:AM450").Copy
End Select
wbThisBook.Activate
Range("EL3").Select
ActiveSheet.Paste

Call DataTransfer

Next intColumn

wbSource.Close SaveChanges:=False
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.DisplayAlerts = True
Application.Calculate
Else: Exit Sub
End If
End If
End Sub

Sub DataTransfer()
Dim intPos As Integer
Dim i As Integer
Dim strMissing As String
Dim t() As Variant
Dim sht As Integer
Dim intLast As Integer
x = Range("EL3:EL450")
y = Range("EM3:EM450")
z = Range("EN3:EN450")

strMsg = "The following items were in your source file but were not found
in your Master Workbook."
strMsg = strMsg & vbCrLf & "You may wish to add them to your Master
Workbook." & vbCrLf
i = 1
On Error Resume Next
For i = 1 To UBound(x)
intPos = 0
intPos = Application.WorksheetFunction.Match(x(i, 1),
ActiveSheet.Range("A3:A450"), 0)
intPos = intPos + 2
If Not IsError(intPos) Then
If intPos = 2 Then
wbSource.Activate
strMissing = Range("A3:A450").Find(x(i,
1)).Offset(0, 2)
strMsg = strMsg & vbCrLf & strMissing
ThisWorkbook.Activate
'UserForm1.ListBox1.AddItem strMissing
Else
With ActiveSheet
intcolumn2 = intColumn
Select Case intcolumn2
Case 1
If y(i, 1) < "" Then
.Cells(intPos, 41) = y(i, 1)
End If
If z(i, 1) < "" Then
.Cells(intPos, 42) = z(i, 1)
End If
Case 2
If y(i, 1) < "" Then
.Cells(intPos, 47) = y(i, 1)
End If
If z(i, 1) < "" Then
.Cells(intPos, 48) = z(i, 1)
End If
Case 3
If y(i, 1) < "" Then
.Cells(intPos, 53) = y(i, 1)
End If
If z(i, 1) < "" Then
.Cells(intPos, 54) = z(i, 1)
End If
Case 4
If y(i, 1) < "" Then
.Cells(intPos, 59) = y(i, 1)
End If
If z(i, 1) < "" Then
.Cells(intPos, 60) = z(i, 1)
End If
Case 5
If y(i, 1) < "" Then
.Cells(intPos, 65) = y(i, 1)
End If
If z(i, 1) < "" Then
.Cells(intPos, 66) = z(i, 1)
End If
Case 6
If y(i, 1) < "" Then
.Cells(intPos, 71) = y(i, 1)
End If
If z(i, 1) < "" Then
.Cells(intPos, 73) = z(i, 1)
End If
Case 7
If y(i, 1) < "" Then
.Cells(intPos, 77) = y(i, 1)
End If
If z(i, 1) < "" Then
.Cells(intPos, 78) = z(i, 1)
End If
Case 8
If y(i, 1) < "" Then
.Cells(intPos, 83) = y(i, 1)
End If
If z(i, 1) < "" Then
.Cells(intPos, 84) = z(i, 1)
End If
Case 9
If y(i, 1) < "" Then
.Cells(intPos, 89) = y(i, 1)
End If
If z(i, 1) < "" Then
.Cells(intPos, 90) = z(i, 1)
End If
Case 10
If y(i, 1) < "" Then
.Cells(intPos, 95) = y(i, 1)
End If
If z(i, 1) < "" Then
.Cells(intPos, 96) = z(i, 1)
End If
Case 11
If y(i, 1) < "" Then
.Cells(intPos, 101) = y(i, 1)
End If
If z(i, 1) < "" Then
.Cells(intPos, 102) = z(i, 1)
End If
Case 15
If y(i, 1) < "" Then
.Cells(intPos, 107) = y(i, 1)
End If
If z(i, 1) < "" Then
.Cells(intPos, 108) = z(i, 1)
End If
Case 16
If y(i, 1) < "" Then
.Cells(intPos, 39) = y(i, 1)
End If
End Select
PercentDone = (intColumn + intcolumn2) / 32
Call UpdateProgress(PercentDone)
End With
End If
End If
Next i

If UserForm1.ListBox1.ListCount 0 Then
UserForm1.Show vbModeless
' Application.EnableEvents = True
' sht = ActiveSheet.Index
' intLast = Range("B9").End(xlDown).Row + 1
' 'intLast = GetLastRows(sht)
'
' For i = 0 To UserForm1.ListBox1.ListCount
' intLast = intLast + 1
' Cells(intLast, 2).Value = UserForm1.ListBox1.List(i)
' Next i
End If
End Sub


Reply
Thread Tools Search this Thread
Search this Thread:

Advanced Search
Display Modes

Posting Rules

Smilies are On
[IMG] code is On
HTML code is Off
Trackbacks are On
Pingbacks are On
Refbacks are On


Similar Threads
Thread Thread Starter Forum Replies Last Post
Still problem with larg file size... DaveyJones Excel Discussion (Misc queries) 2 September 1st 06 01:19 PM
File Size Problem Wayne Knazek Excel Worksheet Functions 1 August 28th 06 12:28 PM
File Size Problem Wayne Knazek Excel Programming 2 August 24th 06 02:26 PM
File Size a real problem! Wayne Knazek Excel Discussion (Misc queries) 3 August 24th 06 12:40 AM
File size problem ??? Michael Beckinsale Excel Programming 2 January 27th 06 03:59 PM


All times are GMT +1. The time now is 01:36 AM.

Powered by vBulletin® Copyright ©2000 - 2024, Jelsoft Enterprises Ltd.
Copyright ©2004-2024 ExcelBanter.
The comments are property of their posters.
 

About Us

"It's about Microsoft Excel"