Select Case in VBA

P

PippaThePointer

New Member
Joined
Sep 21, 2023
Messages
31
Office Version
  1. 2016
Platform
  1. Windows
Hi, I have a VBA Macro that i have been working on based on some awsome input from riv01 on this site. Ive been picking it appart and learning how each bit works and making changes but im stuck on the select case that i have in here as it will only go up to 9.
What it does near the end of the marcro is it sorts all the data into a column based on its size and which row it came from and then add in some text for the file name that relates to the size and the store name. When i started this i only had 3 columns for stores but now there could be many. Idealy a loop would be good but im not sure how to include that with all the other loops that are already in here.
What i tried to do is increase the number of 'Case Select' and then have a prompt for the user to specify what is the last column to get data from. This works but only up to the 9th column. After that it seems to repeat case 9 (Case 10 will reference 9) and then go back to case 1 (case 11 wil be 1, case 12 will be 2 and so on).

Not sure how to get around this.
example below with 14 stores

Store1Store2Store3Store4Store5Store6Store7Store8Store9Store10Store11Store12Store13Store14
P
NameSize
D9200mmx200mm
1​
2​
3​
4​
5​
6​
7​
8​
9​
10​
11​
12​
13​
14​
D10200mmx200mm
1​
2​
3​
4​
5​
6​
7​
8​
9​
10​
11​
12​
13​
14​

VBA Code: 
Sub CreateControlTEST()
    Dim WB As Workbook
    Dim WS As Worksheet, WSD As Worksheet
    Dim rng As Range, R As Range, rng2 As Range
    Dim FirstDataCol As String, LastDataCol As String
    Dim FirstDataRow As Long
    Dim I As Long, LastRow As Long, DestRow As Long, DestColumn As Long
    Dim VA As Variant
    Dim DocName As String, LastSize As String, OutFile As String
    Dim inputfolder As String, outputfolder As String, reportfile As String, overwrite As String, padtoeven As String, author As String, title As String
    Dim JobNumber As String
    JobNumber = InputBox("What is the job number?")
    Range("A3").Value = JobNumber
    LastDataCol = InputBox("enter column letter of last store data")

    '===============User data ========================
    'change inputs below
    inputfolder = "C:\Users\addpath"
    outputfolder = "C:\Users\addpath"
    reportfile = "C:\Users\addpath\" & JobNumber & "_Log.htm"
    overwrite = "no"
    padtoeven = "no"
    author = "user"
    title = JobNumber
    OutFile = "C:\Users\addpath\" & JobNumber & ".txt"
    '=================================================
    Application.ScreenUpdating = False
    Set WB = ActiveWorkbook
    Set WS = ActiveSheet

    'Add temporary worksheet and copy data to it.
    On Error Resume Next
    Application.DisplayAlerts = False
    ThisWorkbook.Worksheets("$TempSheet").Delete
    Application.DisplayAlerts = True
    On Error GoTo 0

    Set WSD = ThisWorkbook.Worksheets.Add
    WSD.Name = "$TempSheet"

    'Define the columns containing the relevant data here.
    FirstDataCol = "A"
    FirstDataRow = 9

    With WS
        Set rng2 = .Range(FirstDataCol & FirstDataRow & ":" & LastDataCol & .Range(FirstDataCol & .Rows.Count).End(xlUp).Row)
    End With

    rng2.Copy
    WSD.Range("A2").PasteSpecial (xlPasteValues)      'copy data to temporary worksheet
    WSD.Columns.AutoFit

    'create formatted text
    With WSD
        Set rng = .Range("B2", .Range("B" & .Rows.Count).End(xlUp))
        rng.Range("A1").Offset(-1, -1).Value = 0
        rng.Range("A1").Offset(-1, 0).Value = 0
        For Each R In rng
            For I = 1 To rng2.Columns.Count - 1
                rng.Range("A1").Offset(-1, I).Value = I
                If Trim(R.Offset(0, I).Value) = "" Then
                    R.Offset(0, I).Value = "Delete"
                Else
                    R.Offset(0, I).Value = "duplicate=" & R.Offset(0, I).Value & "," & R.Offset(0, -1).Value & "$" & I
                End If
            Next I
        Next R
        WSD.Columns.AutoFit
        Columns("A").Delete

        For I = 2 To rng2.Columns.Count - 1
            LastRow = .Range("B" & .Rows.Count).End(xlUp).Row
            rng.Offset(, I).Resize(, 1).Cut .Cells(LastRow + 1, 2)
            rng.Copy .Cells(LastRow + 1, 1)
        Next I

        'Sort
        .UsedRange.Sort Key1:=.Range("A1"), Order1:=xlAscending, Header:=xlYes

        Set rng = .Range("A1", .Range("A" & .Rows.Count).End(xlUp))

        'Delete empty cells
        With rng.Resize(, 2)
            .AutoFilter Field:=2, Criteria1:="=Delete"
            If Not .SpecialCells(xlCellTypeVisible) Is Nothing Then
                .SpecialCells(xlCellTypeVisible).EntireRow.Delete
            End If
        End With
        .AutoFilterMode = False

        DestRow = 1
        DestColumn = 10

        'Write header information
        WriteLine WSD, "inputfolder=" & inputfolder, DestRow, DestColumn
        WriteLine WSD, "outputfolder=" & outputfolder, DestRow, DestColumn
        WriteLine WSD, "reportfile=" & reportfile, DestRow, DestColumn
        WriteLine WSD, "overwrite=" & overwrite, DestRow, DestColumn
        WriteLine WSD, "padtoeven=" & padtoeven, DestRow, DestColumn
        WriteLine WSD, "author=" & author, DestRow, DestColumn
        WriteLine WSD, "title=" & title, DestRow, DestColumn

        'Build formatted text
        LastSize = ""
        For Each R In rng
            R.Value = R.Value & "$" & Right(R.Offset(, 1).Value, 1)
            With R.Offset(, 1)
                VA = Split(.Value, "$")
                .Value = VA(0)
           
            End With
            If LastSize = "" Then
                WriteLine WSD, "<begindoc>", DestRow, DestColumn
            ElseIf R.Value <> LastSize Then
                WriteLine WSD, DocName, DestRow, DestColumn
                WriteLine WSD, "<enddoc>", DestRow, DestColumn
                WriteLine WSD, "<begindoc>", DestRow, DestColumn
            End If
            WriteLine WSD, R.Offset(, 1).Value, DestRow, DestColumn
            VA = Split(R.Value, "$")
            'get header info for store name
            Select Case VA(1)
            Case 1
                 DocName = "document=" & JobNumber & "_" & WS.Range("C2").Value & "_" & VA(0) & ".pdf"
            Case 2
                 DocName = "document=" & JobNumber & "_" & WS.Range("D2").Value & "_" & VA(0) & ".pdf"
            Case 3
                 DocName = "document=" & JobNumber & "_" & WS.Range("E2").Value & "_" & VA(0) & ".pdf"
            Case 4
                 DocName = "document=" & JobNumber & "_" & WS.Range("F2").Value & "_" & VA(0) & ".pdf"
            Case 5
                 DocName = "document=" & JobNumber & "_" & WS.Range("G2").Value & "_" & VA(0) & ".pdf"
            Case 6
                 DocName = "document=" & JobNumber & "_" & WS.Range("H2").Value & "_" & VA(0) & ".pdf"
            Case 7
                 DocName = "document=" & JobNumber & "_" & WS.Range("I2").Value & "_" & VA(0) & ".pdf"
            Case 8
                 DocName = "document=" & JobNumber & "_" & WS.Range("J2").Value & "_" & VA(0) & ".pdf"
            Case 9
                 DocName = "document=" & JobNumber & "_" & WS.Range("K2").Value & "_" & VA(0) & ".pdf"
            Case 10
                 DocName = "document=" & JobNumber & "_" & WS.Range("L2").Value & "_" & VA(0) & ".pdf"
            Case 11
                 DocName = "document=" & JobNumber & "_" & WS.Range("M2").Value & "_" & VA(0) & ".pdf"
            Case 12
                 DocName = "document=" & JobNumber & "_" & WS.Range("N2").Value & "_" & VA(0) & ".pdf"
            Case 13
                 DocName = "document=" & JobNumber & "_" & WS.Range("O2").Value & "_" & VA(0) & ".pdf"
            Case 14
                 DocName = "document=" & JobNumber & "_" & WS.Range("P2").Value & "_" & VA(0) & ".pdf"
            Case 15
                 DocName = "document=" & JobNumber & "_" & WS.Range("Q2").Value & "_" & VA(0) & ".pdf"
            Case 16
                 DocName = "document=" & JobNumber & "_" & WS.Range("R2").Value & "_" & VA(0) & ".pdf"
            Case 17
                 DocName = "document=" & JobNumber & "_" & WS.Range("S2").Value & "_" & VA(0) & ".pdf"
            Case 18
                 DocName = "document=" & JobNumber & "_" & WS.Range("T2").Value & "_" & VA(0) & ".pdf"
            Case 19
                 DocName = "document=" & JobNumber & "_" & WS.Range("E2").Value & "_" & VA(0) & ".pdf"
            Case 20
                 DocName = "document=" & JobNumber & "_" & WS.Range("F2").Value & "_" & VA(0) & ".pdf"

        End Select
            LastSize = R.Value
        Next R

        WriteLine WSD, DocName, DestRow, DestColumn
        WriteLine WSD, "<enddoc>", DestRow, DestColumn

        'Write to text file.
        Set rng = .Range(.Cells(1, DestColumn), .Cells(.Rows.Count, DestColumn).End(xlUp))
        Open OutFile For Output Access Write As #1    ' Open text file for write
        For Each R In rng
            Print #1, R.Value                         ' Write to output file
        Next R
        Close #1                                      ' Close file.
        .Columns.AutoFit
    End With

    'Clean up
    On Error Resume Next
    Application.DisplayAlerts = False
    WSD.Delete
    Application.DisplayAlerts = True
    On Error GoTo 0
    Application.ScreenUpdating = True

    MsgBox "New file created:" & vbCr & vbCr & OutFile, vbOKOnly Or vbInformation, Application.Name
End Sub

Private Sub WriteLine(DestWS As Worksheet, WriteStr As String, ByRef DestRow As Long, ByRef DestColumn As Long)
    DestWS.Cells(DestRow, DestColumn).Value = WriteStr
    DestRow = DestRow + 1
End Sub
 
Last edited by a moderator:

Excel Facts

Control Word Wrap
Press Alt+Enter to move to a new row in a cell. Lets you control where the words wrap.
Sort by date Sort by votes
Seems to me that your issue is here:
R.Value = R.Value & "$" & Right(R.Offset(, 1).Value, 1)
You are only picking the last character. That's why if text is 200mmx200mm$01$D9 it picks "9" but if 200mmx200mm$01$D11 it will pick "1" and not "11".

Here is my suggestion but I have only given a quick check to your macro (would need going much deeper), so have a try with:
Change this line where you generate the text:
R.Offset(0, I).Value = "duplicate=" & R.Offset(0, I).Value & "," & R.Offset(0, -1).Value & "$" & I
to have a two digit number:
R.Offset(0, I).Value = "duplicate=" & R.Offset(0, I).Value & "," & R.Offset(0, -1).Value & "$" & Format(I, "00")
And then change this one where you pick the number for the Select/Case:
R.Value = R.Value & "$" & Right(R.Offset(, 1).Value, 1)
to pick two characters:
R.Value = R.Value & "$" & Right(R.Offset(, 1).Value, 2)
 
Upvote 0
Solution
rollis13 said:
Seems to me that your issue is here:
R.Value = R.Value & "$" & Right(R.Offset(, 1).Value, 1)
You are only picking the last character. That's why if text is 200mmx200mm$01$D9 it picks "9" but if 200mmx200mm$01$D11 it will pick "1" and not "11".

Here is my suggestion but I have only given a quick check to your macro (would need going much deeper), so have a try with:
Change this line where you generate the text:
R.Offset(0, I).Value = "duplicate=" & R.Offset(0, I).Value & "," & R.Offset(0, -1).Value & "$" & I
to have a two digit number:
R.Offset(0, I).Value = "duplicate=" & R.Offset(0, I).Value & "," & R.Offset(0, -1).Value & "$" & Format(I, "00")
And then change this one where you pick the number for the Select/Case:
R.Value = R.Value & "$" & Right(R.Offset(, 1).Value, 1)
to pick two characters:
R.Value = R.Value & "$" & Right(R.Offset(, 1).Value, 2)
Click to expand...
Genius! Thank you. I guessed it was only looking at first matching digit but coulnt work out where to change it. Your suggestion worked.
 
Upvote 0
Thanks for the positive feedback(y), glad having been of some help.
By the way, you probably need to mark this thread as [Solved].
 
Upvote 0
You must log in or register to reply here.

Similar threads

P
  • Solved
Save as text file in a certain format similar to an xml
2
Replies
17
Views
626
PippaThePointer
P
Guna13
  • Question Question
Help to Optimize Macro Code for Faster Performance
Replies
0
Views
979
Guna13
Guna13
N
  • Question Question
VBA code to excel and word populate
Replies
2
Views
1K
nmc
N
gravanoc
  • Question Question
Accessing an open Word doc from Excel causes "Locked for Editing" dialog to appear
Replies
3
Views
1K
NdNoviceHlp
NdNoviceHlp
E
  • Question Question
Help Cleaning Up / Optimizing VBA Code
Replies
6
Views
521
offthelip
O

Forum statistics

Threads
1,223,236
Messages
6,170,917
Members
452,366
Latest member
TePunaBloke

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top