Forum Discussion
JoAvg
Jan 22, 2023Brass Contributor
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.
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
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