PDA

View Full Version : Copying Data Between Sheets



Eratosthenes
02-06-2021, 12:45 PM
Hello all, I'm new here! Just a bit of background, if you're interested; I'm a novice programmer doing technical support for a printing company based in Missouri. I've been tasked with streamlining the processes of printing our box labels, and have hit a snag. Most of the issue comes from the fact that some, but not all, of our computers are Apples. It seems to me that the easiest way to get it to work I have to separate my VBA program from the data it needs to interact with, but this broke my program entirely and I can't seem to fix it no matter what I do.

Here is the code I was using before I tried to separate the files. I'm sorry, it's definitely a mess.

Private Sub EXPORT_Click() Sheets("XML").Range("A1:C13530").Copy
Sheets("UPS").Range("A1").PasteSpecial _
Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Worksheets("UPS").Columns("B").Replace _
What:="#REF!", Replacement:="BAD", _
SearchOrder:=xlByColumns, MatchCase:=True
Last = Cells(Rows.Count, "B").End(xlUp).row
For i = Last To 1 Step -1
If (Cells(i, "B").Value) = "BAD" Then
Cells(i, "B").EntireRow.Delete
End If
Next i
Columns("A:B").EntireColumn.Delete
Dim xRet As Long
Dim xFileName As Variant
On Error GoTo ErrHandler
xFileName = Application.GetSaveAsFilename(ActiveSheet.Name, "XML File (*.xml), *.xml", , "Worldship Exporter")
If xFileName = False Then Exit Sub
If Dir(xFileName) <> "" Then
xRet = MsgBox("File '" & xFileName & "' exists. Overwrite?", vbYesNo + vbExclamation, "Worldship Exporter")
If xRet <> vbYes Then
Exit Sub
Else
Kill xFileName
End If
End If

SaveFile (xFileName)

Exit Sub
ErrHandler:
MsgBox Err.Description, , "Worldship Exporter"
End Sub


Private Sub SaveFile(fileName)
Dim fileNumber As Integer
fileNumber = FreeFile

On Error GoTo ReleaseFileAndThrowError
Open fileName For Output As #fileNumber


Dim row As Integer
Dim cellText As String
Do
row = row + 1
cellText = Cells(row, 1).Value
Print #fileNumber, cellText
Loop While Len(cellText) > 0


Close #fileNumber
Exit Sub


ReleaseFileAndThrowError:
Close #fileNumber
Err.Raise Err.Number
Application.CutCopyMode = False
End Sub


What I'm trying to add here is a method of choosing a file from an explorer window to pull the data from, instead of pulling it from a sheet in the same workbook.

My attempt(s) looks like this, cut off where it becomes irrelevant.


Private Sub EXPORT_Click() Dim strFile As String
Dim wbk As Workbook
Dim lngLastRow As Long
strFile = Application.GetOpenFilename
If strFile = "False" Then
Beep
Exit Sub
End If
Application.ScreenUpdating = False
Set wbk = Workbooks.Open(fileName:=strFile)
With wbk.Worksheets(1)
'lngLastRow = Sheets("XML").Range("A1:C13530").Copy
End With
Workbooks(strFile).Worksheets("XML").Range("A1:C13530").Copy _
Workbooks("RLConverter.xlsm").Worksheets("UPS").Range("A1")
'wbk.Close False
'Sheets("UPS").Activate
'Set wbk = Workbooks.Open("\\ARCADESERVER\Shared Folder 2\Jacob's Programming Files\RLConverter.xlsm")
'Sheets("UPS").Range("A1").PasteSpecial _
'Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
':=False, Transpose:=False
Application.CutCopyMode = False
Sheets("UPS").Columns("B").Replace _
What:="#REF!", Replacement:="BAD", _
SearchOrder:=xlByColumns, MatchCase:=True
Last = Sheets("UPS").Cells(Rows.Count, "B").End(xlUp).row
For i = Last To 1 Step -1
If (Sheets("UPS").Cells(i, "B").Value) = "BAD" Then
Sheets("UPS").Cells(i, "B").EntireRow.Delete
End If
Next i
Sheets("UPS").Columns("A:B").EntireColumn.Delete


Attached, hopefully, are the following files for reference;

Runlist Template: This is a working version of my code, contained within the same worksheet as the data.

RLConverter: This is the converter program, separated from the data, that currently doesn't work.



TLDR; I'm not really sure what I'm doing. I'm to copy data from a different workbook every use, do some stuff to it, then export it in XML format of use in uploading to another program. Please help!

jolivanes
02-06-2021, 09:29 PM
Two same workbooks with empty sheets except one more sheet in one with data in three Columns.
Attach a workbook with a before and after and an explanation on how you arrived at the "after".

siech
02-07-2021, 10:09 AM
Hello Eratosthenes,

I'm new too and a few months ago I would probably have written the same type of code as what you posted. So after learning, this is my first post in trying to give back and to continue my vba learning journey in doing it.
Basically you are trying to automatise in vba what you would do in Excel, but vba will work much better for you if you use arrays instead. Basically any of your scripts will work much faster if you:

Load your data in memory ( an array, collection, dictionary);
transform your data in memory;
write back to your sheet only when all is done;


So based on the above hereunder alternative version based on what I understood. What this script will do is:

Open an explorer window for the user to choose the source file
Note: you will need to elaborate this as the "Application.GetOpenFilename" will not work on MAC! alternatively you could just show a msgBox asking the user to fill in manually the filename.
Load the data in memory and remove the lines with an "#REF!" error, it will also delete the first 2 cols.
write the modified data back to the sheet
Save the file as an xml file, using the tab name as filename. If the file already exists the user can decide not to save it, in that case the sub will just exit without closing the file
close the file


I commented most lines directly in the code.

best of luck,

Siech





Option Explicit
Option Base 1


Sub ImportData()
'load the source file based on user input to an array
Dim filename As String, Data, ws As Worksheet
Set ws = Worksheets(1)
filename = Application.GetOpenFilename
Data = openfile(filename)

'create a new target array based on the size of the original array minus the 2 colls we will delete
Dim j As Long, jj As Long, i As Long, Tarr
ReDim Tarr(1 To UBound(Data), 1 To UBound(Data, 2) - 2)

For j = 1 To UBound(Data) 'loop trough the source lines
jj = jj + 1 'set an alternative counter for the target array, this one will skip the lines we want to delete
For i = 1 To UBound(Data, 2) - 2 'loop trough the cols of the source minus the 2 colls we want to delete
j = IIf((CStr(Data(j, 2)) = "Error 2023"), j + 1, j) 'delete the line if "#REF!" error
Tarr(jj, i) = Data(j, i + 2) 'set the source data in the target array. if a line must be deleted the jj counter will be e.g 2 vs 3 from the source
Next i
Next j

'paste to sheet
ws.Range("A1").Resize(jj, UBound(Tarr, 2)).Value2 = Tarr

'Save
On Error GoTo ErrorHandler 'if the user chooses to not overwrite the existing file we exit the sub
ws.SaveAs filename:=ws.Name, FileFormat:=xlXMLSpreadsheet 'save as xml using the tabname, if the file exists the user will get a prompt
ActiveWorkbook.Close savechanges:=False 'close the file

'exit
ErrorHandler:
Exit Sub
End Sub


Private Function openfile(filename As String) As Variant
'import External
Dim wbExt As Workbook, Data, FilePath As String
'FilePath = Application.ActiveWorkbook.Path & filename => alternative if you just ask a filename to the user. this will set the path.
Set wbExt = Workbooks.Open(filename:=filename) 'replace filename with filepath if you choose above approach
With wbExt: Data = .Sheets(1).UsedRange.Value: .Close: End With 'get data from source and close
openfile = Data 'send array back to main sub
End Function