Results 1 to 2 of 2
  1. #1
    Join Date
    Nov 2015
    Posts
    1

    Unanswered: Help on Macro please!

    Hello

    I have a macro in VBA that is given to the user, the user is presented with a menu, it allows the user to select a worksheet delete a number of rows and extract it as a CSV to their local computer, this allows inport into an application. I am running into block if without endif errors. The majorty of row to be deleted is 11 which is a standard number of rows to delete however now I am faced with some worksheet requiring the first 50 rows deleted before its extract as a csv, some others require 20. Any help will be appreciated....Below you will see the work one after the problem one

    Sub SheetActivater()
    Const ColItems As Long = 15
    Const LetterWidth As Long = 15
    Const HeightRowz As Long = 18
    Const SheetID As String = "__SheetSelection"
    Dim i%, TopPos%, iSet%, optCols%, intLetters%, optMaxChars%, optLeft%
    Dim wsDlg As DialogSheet, objOpt As OptionButton, optCaption$, objSheet As Object
    optCaption = "": i = 0
    Application.ScreenUpdating = False
    MsgBox "Have you saved this spreadsheet into a folder called DODO on your desktop?"
    On Error Resume Next
    Application.DisplayAlerts = False
    ActiveWorkbook.DialogSheets(SheetID).Delete
    Application.DisplayAlerts = True
    Err.Clear
    Set wsDlg = ActiveWorkbook.DialogSheets.Add
    With wsDlg
    .Name = SheetID
    .Visible = xlSheetHidden
    iSet = 0: optCols = 0: optMaxChars = 0: optLeft = 78: TopPos = 40
    For Each objSheet In ActiveWorkbook.Sheets
    If objSheet.Visible = xlSheetVisible Then
    i = i + 1
    If i Mod ColItems = 1 Then
    optCols = optCols + 1
    TopPos = 40
    optLeft = optLeft + (optMaxChars * LetterWidth)
    optMaxChars = 0
    End If
    intLetters = Len(objSheet.Name)
    If intLetters > optMaxChars Then optMaxChars = intLetters
    iSet = iSet + 1
    .OptionButtons.Add optLeft, TopPos, intLetters * LetterWidth, 16.5
    .ObjSelection.Font.Color = RGB(0, 255, 0)
    .OptionButtons(iSet).Text = objSheet.Name
    TopPos = TopPos + 10
    End If
    Next objSheet
    If i > 0 Then
    .Buttons.Left = optLeft + (optMaxChars * LetterWidth) + 2
    With .DialogFrame
    .Height = Application.Max(68, WorksheetFunction.Min(iSet, ColItems) * HeightRowz + 2)
    .Width = optLeft + (optMaxChars * LetterWidth) + 2
    .Caption = "Select the table(s) you want to export as a CSV?"
    End With
    .Buttons("Button 2").BringToFront
    .Buttons("Button 3").BringToFront
    If .Show = True Then
    For Each objOpt In wsDlg.OptionButtons
    If objOpt.Value = xlOn Then
    optCaption = objOpt.Caption
    Exit For
    End If
    Next objOpt
    End If
    If optCaption = "" Then
    MsgBox "You did not select a worksheet.", 48, "Cannot continue"
    Application.ScreenUpdating = True
    Exit Sub
    Else
    'MsgBox "You selected the sheet named ''" & optCaption & "''." & vbCrLf & "Click OK to go there.", 64, "FYI:"
    Sheets(optCaption).Activate


    With ws.Name = "Payment_Source"
    With ws.Name = "Waiver Service"
    With ws.Name = "Waiver_Type"


    ws.Rows("1:12").Delete ' Delete 10 rows at top of each sheet.
    ws.Copy
    Range("A1").Interior.Color = 1 ' Format A1 so the top rows are included in the used range and saved
    ActiveWorkbook.SaveAs Filename:=path & "_" & ws.Name & ".csv", FileFormat:=xlCSV, CreateBackup:=False
    ActiveWorkbook.Close SaveChanges = False
    End With


    With ws.Name = "Provider"

    ws.Rows("1:40").Delete ' Delete 10 rows at top of each sheet.
    ws.Copy
    Range("A1").Interior.Color = 1 ' Format A1 so the top rows are included in the used range and saved
    ActiveWorkbook.SaveAs Filename:=path & "_" & ws.Name & ".csv", FileFormat:=xlCSV, CreateBackup:=False
    ActiveWorkbook.Close SaveChanges = False
    End With


    With ws.Name = "Provider_Payor_Link"

    ws.Rows("1:13").Delete ' Delete 10 rows at top of each sheet.
    ws.Copy
    Range("A1").Interior.Color = 1 ' Format A1 so the top rows are included in the used range and saved
    ActiveWorkbook.SaveAs Filename:=path & "_" & ws.Name & ".csv", FileFormat:=xlCSV, CreateBackup:=False
    ActiveWorkbook.Close SaveChanges = False
    End With


    With ws.Name = "Service_Code"

    ws.Rows("1:51").Delete ' Delete 10 rows at top of each sheet.
    ws.Copy
    Range("A1").Interior.Color = 1 ' Format A1 so the top rows are included in the used range and saved
    ActiveWorkbook.SaveAs Filename:=path & "_" & ws.Name & ".csv", FileFormat:=xlCSV, CreateBackup:=False
    ActiveWorkbook.Close SaveChanges = False
    End With


    With ws.Name = "Source"

    ws.Rows("1:28").Delete ' Delete 10 rows at top of each sheet.
    ws.Copy
    Range("A1").Interior.Color = 1 ' Format A1 so the top rows are included in the used range and saved
    ActiveWorkbook.SaveAs Filename:=path & "_" & ws.Name & ".csv", FileFormat:=xlCSV, CreateBackup:=False
    ActiveWorkbook.Close SaveChanges = False
    End With

    With ws.Name = "ICD Diagnosis", "Election:

    ws.Rows("1:11").Delete ' Delete 10 rows at top of each sheet.
    ws.Copy
    Range("A1").Interior.Color = 1 ' Format A1 so the top rows are included in the used range and saved
    ActiveWorkbook.SaveAs Filename:=path & "_" & ws.Name & ".csv", FileFormat:=xlCSV, CreateBackup:=False
    ActiveWorkbook.Close SaveChanges = False
    End With









    strFormWS = optCaption


    Application.DisplayAlerts = False
    .Delete
    Application.DisplayAlerts = True


    MsgBox "Done! If you need to do another export please return to the Export to CSV menu and select again or exit this spreadsheet without saving"
    MsgBox "If you have problems importing run the CleanCSV function and retry inport into DODO"
    End If


    End Sub





    Sub SheetActivater()
    Const ColItems As Long = 15
    Const LetterWidth As Long = 15
    Const HeightRowz As Long = 18
    Const SheetID As String = "__SheetSelection"
    Dim i%, TopPos%, iSet%, optCols%, intLetters%, optMaxChars%, optLeft%
    Dim wsDlg As DialogSheet, objOpt As OptionButton, optCaption$, objSheet As Object
    optCaption = "": i = 0
    Application.ScreenUpdating = False
    MsgBox "Have you saved this spreadsheet into a folder called dodo on your desktop?"
    On Error Resume Next
    Application.DisplayAlerts = False
    ActiveWorkbook.DialogSheets(SheetID).Delete
    Application.DisplayAlerts = True
    Err.Clear
    Set wsDlg = ActiveWorkbook.DialogSheets.Add
    With wsDlg
    .Name = SheetID
    .Visible = xlSheetHidden
    iSet = 0: optCols = 0: optMaxChars = 0: optLeft = 78: TopPos = 40
    For Each objSheet In ActiveWorkbook.Sheets
    If objSheet.Visible = xlSheetVisible Then
    i = i + 1
    If i Mod ColItems = 1 Then
    optCols = optCols + 1
    TopPos = 40
    optLeft = optLeft + (optMaxChars * LetterWidth)
    optMaxChars = 0
    End If
    intLetters = Len(objSheet.Name)
    If intLetters > optMaxChars Then optMaxChars = intLetters
    iSet = iSet + 1
    .OptionButtons.Add optLeft, TopPos, intLetters * LetterWidth, 16.5
    .ObjSelection.Font.Color = RGB(0, 255, 0)
    .OptionButtons(iSet).Text = objSheet.Name
    TopPos = TopPos + 10
    End If
    Next objSheet
    If i > 0 Then
    .Buttons.Left = optLeft + (optMaxChars * LetterWidth) + 2
    With .DialogFrame
    .Height = Application.Max(68, WorksheetFunction.Min(iSet, ColItems) * HeightRowz + 2)
    .Width = optLeft + (optMaxChars * LetterWidth) + 2
    .Caption = "Select the table(s) you want to export as a CSV?"
    End With
    .Buttons("Button 2").BringToFront
    .Buttons("Button 3").BringToFront
    If .Show = True Then
    For Each objOpt In wsDlg.OptionButtons
    If objOpt.Value = xlOn Then
    optCaption = objOpt.Caption
    Exit For
    End If
    Next objOpt
    End If
    If optCaption = "" Then
    MsgBox "You did not select a worksheet.", 48, "Cannot continue"
    Application.ScreenUpdating = True
    Exit Sub
    Else
    'MsgBox "You selected the sheet named ''" & optCaption & "''." & vbCrLf & "Click OK to go there.", 64, "FYI:"
    Sheets(optCaption).Activate


    For Each ws In ActiveWindow.SelectedSheets

    ws.Rows("1:10").Delete ' Delete 10 rows at top of each sheet.
    ws.Copy
    Range("A1").Interior.Color = 1 ' Format A1 so the top rows are included in the used range and saved
    ActiveWorkbook.SaveAs Filename:=path & "_" & ws.Name & ".csv", FileFormat:=xlCSV, CreateBackup:=False
    ActiveWorkbook.Close SaveChanges = False

    Next ws



    strFormWS = optCaption
    End If
    End If
    Application.DisplayAlerts = False
    .Delete
    Application.DisplayAlerts = True
    End With
    Application.ScreenUpdating = True

    MsgBox "Done! If you need to do another export please return to the Export to CSV menu and select again or exit this spreadsheet without saving"
    MsgBox "If you have problems importing run the CleanCSV function and retry inport into Dodo"



    End Sub
    Last edited by hajduk1908; 11-06-15 at 00:25.

  2. #2
    Join Date
    Sep 2006
    Location
    Surrey, UK
    Posts
    995
    Provided Answers: 2
    I doubt that you'll find someone willing to proof-read your code, even if you had used the code tags.

    What I tend to do in this situation is to copy the code to a text file and then copy it back a line at a time. However, when I paste a line that opens a flow control structure (IF, WITH, DO, FOR, etc), I immediately add the required termination line beneath it, and then add the required code between the two.
    10% of magic is knowing something that no-one else does. The rest is misdirection.

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •