1
\$\begingroup\$

I have a macro where I open several text files to copy and transpose several columns into my worksheet. As it is now this actually works. I am right now opening the text file, copying a column, going back to my original worksheet pasting and transposing the data, then switching back and forward between the two sheets until all relevant columns have been copied, then I close down the text file and open a new one...

I figured it could probably be optimized if I understood VBA a little better.

My question is: can I save the column data as ranges instead and then copy it all at once and pasting and transposing it all at once as well? Or is there any other ways to improve my macro?

I have shown an example of my code below hope you can make sense of it (I have only shown the import of one column, the rest follow the same code):

Sub Hent_og_Transponer()

Dim f As String

    f = ActiveWorkbook.Name

'Select files for import

    Dim K As Integer
    FILOPEN = Application.GetOpenFilename("Files (*.txt; *.jpg; *.bmp; *.tif),*.chr; *_chr.txt; *chr.txt; *.tif", _
        , "Select Picture to Import", MultiSelect:=True)

    If IsArray(FILOPEN) Then
        For K = LBound(FILOPEN) To UBound(FILOPEN)
            Application.ScreenUpdating = False
            Workbooks.OpenText FileName:=FILOPEN(K), _
            Origin:=xlWindows, StartRow:=1, DataType:=xlDelimited, TextQualifier:= _
            xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, Semicolon:=True, _
            Comma:=False, Space:=False, Other:=False, FieldInfo:=Array(1, 2), _
            TrailingMinusNumbers:=True

'Save name of file opened

    Dim z As String

    z = ActiveWorkbook.Name

    Windows(Left(z, Len(z))).Activate

'Copy Temperature Data from opened file

    Range("A1").Select

'Find row with temp data

    Dim RowTemp1 As Range
    Dim RowTemp As Integer

    Set RowTemp1 = Range("B:B").Find("f in Hz", SearchOrder:=xlRows, MatchCase:=False)
    If Not RowTemp1 Is Nothing Then  ' if findrow is something (Prevents Errors)
                RowTemp = RowTemp1.Row      ' set FirstRow to the first time a match is found
    End If

    ActiveSheet.Cells(RowTemp + 1, 1).Select
    Range(Selection, Selection.End(xlDown)).Select

    Selection.Copy

    'Go back to DMA sheet

    Windows(Left(f, Len(f))).Activate

    'Paste and Transpose Temp Data

    If IsEmpty(ActiveSheet.Cells(4, 2).Value) = True Then
            ActiveSheet.Cells(4, 1).Select
            ActiveCell.Offset(0, 1).Range("A1").Select
                Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                :=False, Transpose:=True

                ActiveSheet.Cells(4 + 5 + Range("A2").Value, 1).Select
                ActiveCell.Offset(0, 1).Range("A1").Select
                Selection.PasteSpecial Paste:=xlPasteValues, 

Operation:=xlNone, SkipBlanks _
                    :=False, Transpose:=True
            End If
'Here I continue to do the same with different columns...

    Next K
    End If
End Sub

Textfile:

Date / Time / Version: 29.03.2019 / 7:21:01 / HAAKE RheoWin 4.82.0001 Substance / Sample no: pasta mix vége run1 / pasta mix vége run1

;f in Hz;|G*| in Pa;tan(delta) in -;Fn in N;h in mm; 1|1;10,0;1736000;0,650;0,505;1,05; 1|2;5,62;1431000;0,603;0,486;1,05; 1|3;3,16;1203000;0,575;0,510;1,05; 1|4;1,78;1016000;0,561;0,481;1,05; 1|5;1,00;857000;0,565;0,471;1,05; 1|6;0,562;722300;0,585;0,447;1,05; 1|7;0,316;608300;0,619;0,437;1,05; 1|8;0,178;505200;0,664;0,422;1,05; 1|9;0,100;413900;0,715;0,383;1,05; 2|1;0,0562;328400;0,771;0,338;1,05; 2|2;0,0316;264700;0,827;0,297;1,05; 2|3;0,0178;208000;0,871;0,252;1,05; 2|4;0,0100;159600;0,907;0,203;1,05; 2|5;0,00562;129800;0,916;0,158;1,05; 2|6;0,00316;98510;0,913;0,114;1,05;

\$\endgroup\$
  • \$\begingroup\$ The process can be improved. Do you have an example text file? Why do you have image filters in your file dialog? \$\endgroup\$ – TinMan Apr 6 at 19:59
  • \$\begingroup\$ Bad formatting/indenting, using GoTos, incomplete routine (where is the sub/function signature?), really crazy code that shows very little thought when copying someone else's code (Left(z, Len(z))), missing labels (Data2:) which in themselves is real code stink, activating windows for what purpose?. I am not going to review this, because my basic first comment is to scrap the code and then rewrite the logic. \$\endgroup\$ – AJD Apr 7 at 0:12
  • \$\begingroup\$ @TinMan , the image part is a mistake. I got this bit of code of somewhere and as it worked I did not consider that the text was wrong. But that should be an easy fix. I have added the textfile below the code - did not know how to attach it. \$\endgroup\$ – Lonnie Apr 7 at 6:26
  • \$\begingroup\$ @ADJ The GoTo code is something I was trying to implement as the first two columns I import from each textfile will be the same, so figured I would skip this part when I imported the second text file etc... I have removed the code as this part actually did not run yet. \$\endgroup\$ – Lonnie Apr 7 at 6:28
  • \$\begingroup\$ Your code does not work with this data "as is". You need to upload the file to a service like Google Drive or Dropbox and then share the link. \$\endgroup\$ – TinMan Apr 7 at 10:12

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Browse other questions tagged or ask your own question.