Forum Discussion

JoAvg's avatar
JoAvg
Brass Contributor
Jan 22, 2023
Solved

Combine macros in one

I have these two codes in sheet TOMH.

I would like to combine these in one macro.

 

1. I would like to run the code from sheet As_Built.

2. The executed order of the macro is as depicted here: first transpose, then save as text.

3. After transpose the macro should wait for 2-3 seconds before saving as it might take a while to fill down the cells.

4. The code should work for as long col DB cells not empty (I used a range r=2 To 300), so I don't get unnecessary empty rows, in case transposed cells are less.

 

 

Sub Transpose2Columns()
    Dim x As Range, y As Range, z As Range
'   ------------------------------------------------------
    Set y = [DA2]
    For Each z In [CF1:CU21].Columns
        For Each x In z.Cells
            If Len(x.Value) > 0 Then
                y.Value = x.Value
                Set y = y.Offset(1, 0)
            End If
        Next x
    Next z
End Sub

Sub SaveRangeAsEXE()
    Dim ws As Worksheet
    Dim f As Integer
    Dim r As Long
    Set ws = Worksheets("TOMH")
    f = FreeFile
    Open CreateObject("WScript.Shell").SpecialFolders("Desktop") & _
        "\EDA_THESS_DWG\EXEC.scr" For Output As #f
    For r = 2 To 300
        Print #f, ws.Range("DB" & r).Value
    Next r
    Close #f
End Sub

 

 

 Thank you.

  • JoAvg 

    No need to wait - the second part of the code won't be executed before the first part ends.

    Sub TransposeAndSaveAsText()
        Dim x As Range, y As Range, z As Range
        Dim ws As Worksheet
        Dim f As Integer
        Dim r As Long
    '   ------------------------------------------------------
        Set ws = Worksheets("TOMH")
        Set y = ws.Range("DA2")
        For Each z In ws.Range("CF1:CU21").Columns
            For Each x In z.Cells
                If Len(x.Value) > 0 Then
                    y.Value = x.Value
                    Set y = y.Offset(1, 0)
                End If
            Next x
        Next z
        f = FreeFile
        Open CreateObject("WScript.Shell").SpecialFolders("Desktop") & _
            "\EDA_THESS_DWG\EXEC.scr" For Output As #f
        r = 2
        Do While ws.Range("DB" & r).Value <> ""
            Print #f, ws.Range("DB" & r).Value
            r = r + 1
        Loop
        Close #f
    End Sub

1 Reply

  • JoAvg 

    No need to wait - the second part of the code won't be executed before the first part ends.

    Sub TransposeAndSaveAsText()
        Dim x As Range, y As Range, z As Range
        Dim ws As Worksheet
        Dim f As Integer
        Dim r As Long
    '   ------------------------------------------------------
        Set ws = Worksheets("TOMH")
        Set y = ws.Range("DA2")
        For Each z In ws.Range("CF1:CU21").Columns
            For Each x In z.Cells
                If Len(x.Value) > 0 Then
                    y.Value = x.Value
                    Set y = y.Offset(1, 0)
                End If
            Next x
        Next z
        f = FreeFile
        Open CreateObject("WScript.Shell").SpecialFolders("Desktop") & _
            "\EDA_THESS_DWG\EXEC.scr" For Output As #f
        r = 2
        Do While ws.Range("DB" & r).Value <> ""
            Print #f, ws.Range("DB" & r).Value
            r = r + 1
        Loop
        Close #f
    End Sub

Resources