When multiple workbooks are open, this macro doesn't work properly at all!

[wittonlin]

I hope you're still around Tetra.


If we run this macro below with only ONE file open it works perfectly!


If multiple files are open, then the filename doesn't get created (i.e. -.csv vs. TueNov01-61.csv), it's doesn't close as it should and it invariably only processes about a 3rd of the records in the file.


We had to keep parameters open because filenames are always changing, not static. I'm sure this has created the problem.


The idea is to convert the active workbook a .csv or .xls file with these columns...


FirstName LastName HomePhone TimeZone StreetAddress City State ZipCode Email IP TimeandDate Gender BTC Priority Reason MostImportant HowMuch Groupname


To a .csv file with the name (i.e. TueNov01-61.csv) and reducing column fields down to these (combining several into a couple columns)...


FirstName LastName Email CompanyName HomePhone StreetAddress City State ZipCode WorkPhone Notes


And both files simply closing quitely with the source file unchanged.


With only ONE open active workbook, it works like a charm!

Option Explicit

Sub CreateMobilCTI_ImportFile()
Dim wb As Workbook
Dim wk1 As Worksheet
Dim wk2 As Worksheet
Dim i As Long, j As Long
Dim mb As String, rply As String

If Workbooks.count >= 2 Then
    Set wb = Workbooks(2)
Else
    Set wb = ThisWorkbook
    mb = "There is no any other Spreadsheet or csv file open" & Chr(10) & "to process the project, please open csv file " & Chr(10) & Chr(10) & "Please Press OK for Exit"

    Exit Sub
End If

wb.Activate

If wb.Worksheets.count <= 1 Then
    wb.Worksheets.Add(, Worksheets(1)).Name = 2
End If

If wb.Worksheets.count >= 3 Then
    For j = wb.Worksheets.count To 3 Step -1
        wb.Worksheets(j).Delete
    Next j
End If

Set wk1 = Worksheets(1)
Set wk2 = Worksheets(2)


Application.DisplayAlerts = False
Application.ScreenUpdating = False
i = 1

Dim pth As String



Do Until IsEmpty(wk1.Cells(i, 1))
    
    
    wk2.Cells(i, 1) = wk1.Cells(i, 1) ' FirstName
    wk2.Cells(i, 2) = wk1.Cells(i, 2) ' LastName
    wk2.Cells(i, 5) = wk1.Cells(i, 3) ' HomePhone
    
    If i = 1 Then
        wk2.Cells(i, 6) = "StreetAddress"     ' StreetAddress
    Else
        wk2.Cells(i, 6) = wk1.Cells(i, 5)
    End If
    wk2.Cells(i, 7) = wk1.Cells(i, 6) ' City
    wk2.Cells(i, 8) = wk1.Cells(i, 7) ' State
    If i = 1 Then
        wk2.Cells(i, 9) = "ZipCode"     ' ZipCode
    Else
        wk2.Cells(i, 9) = wk1.Cells(i, 8)
    End If
    wk2.Cells(i, 3) = wk1.Cells(i, 9) ' Email
    If i = 1 Then
        wk2.Cells(i, 4) = "CompanyName"
    Else
        wk2.Cells(i, 4) = wk1.Cells(i, 12) & ":" & wk1.Cells(i, 13) ' CompanyName
    End If
    If i = 1 Then
        wk2.Cells(i, 11) = "Notes"
    Else
        wk2.Cells(i, 11) = wk1.Cells(i, 11) & ":" & wk1.Cells(i, 14) & ":" & wk1.Cells(i, 15) & ":" & wk1.Cells(i, 16) & ":" & wk1.Cells(i, 17) ' Notes
    End If

    If i = 1 Then
        wk2.Cells(i, 10) = "WorkPhone"
    Else
        wk2.Cells(i, 10) = "" ' WorkPhone
    End If
        Range("I:I").NumberFormat = "00000"
i = i + 1
Loop
i = 2
    
Dim fn1 As String, fn2 As String

' Creating file name

fn1 = Mid(wb.Worksheets(1).Cells(i, 18), 1, 3) & Mid(wb.Worksheets(1).Cells(i, 18), 5, 3) & Mid(wb.Worksheets(1).Cells(i, 18), 9, 2) & " - " & Mid(wb.Worksheets(1).Cells(i, 10), 1, 2)


' Creating path to save

' pth = ActiveWorkbook.Path ' At that time it is path - i.e.Windows default "where  this file was saved"

  pth = "C:\President Files\Leads\Leads Temp\fulfillment\ACTIVE" ' You can change path just like as too


' Check Existing file & Saving
    For j = 1 To 10
        If Dir(pth & "\" & fn1 & ".csv") = "" Then
            wk1.Delete
            wb.SaveAs Filename:=pth & "\" & fn1 & ".csv", FileFormat:=xlCSV ', ConflictResolution:=xlLocalSessionChanges  '    currentBook.Close SaveChanges:=False
            wb.Close
            Exit Sub
        Else
            fn2 = Mid(wb.Worksheets(1).Cells(i, 18), 1, 3) & Mid(wb.Worksheets(1).Cells(i, 18), 5, 3) & Mid(wb.Worksheets(1).Cells(i, 18), 9, 2) & "-" & CLng(Mid(wb.Worksheets(1).Cells(i, 10), 1, 2)) + j
            If Dir(pth & "\" & fn2 & ".csv") = "" Then
                rply = InputBox("File " & pth & "\" & fn1 & ".csv" & vbCrLf & "already exist, Would you like to change this file" & vbCrLf & "with following available name or change name as you like", "CSV File Name", pth & "\" & fn2 & ".csv", vbOKCancel)
                If rply = "" Then
                    MsgBox "File name is not valid"
                    wk1.Delete
                    wb.Close
                    Exit Sub
                Else
                    fn1 = fn2
                End If
            End If
        End If
    Next j
    
    wb.Close
                    Application.DisplayAlerts = True
                    Application.ScreenUpdating = True


End Sub

I sure hope someone can help.

 

[Tetra201]

It's always difficult to troubleshoot someone else's code. However:

If we run this macro below with only ONE file open it works perfectly!
If multiple files are open, then the filename doesn't get created (i.e. -.csv vs. TueNov01-61.csv)...

The above symptoms indicate that in the multi-file case, the required info in wb.Worksheets(1).Cells(2, 18) is missing.

This, in turn, is likely caused by the following line:

If Workbooks.Count >= 2 Then Set wb = Workbooks(2)

Workbooks(2) is just a workbook that had been opened second in a particular instance of Excel. It may/may not be the desired workbook.

Fix this issue and see if it helped.

 

[wittonlin]

Yeah the code's not pretty. It's pieced together some from a previous project. Yeah we're using the 2nd worksheet to do the processing so we can pull what we need, leave the source file unchanged and move that to a new file and close. Does that make sense?

I think I misunderstood. If you're saying to change it. I wouldn't know what to change it to. One thing is that we rarely use sheet2 and if we do it's like this one, get in, get out and delete it.

 

[Tetra201]

I am talking about Workbooks(2) (that is, an Excel file), not about Worksheets(2) (a sheet inside the file).

The line I was referring to is immediately below the Dim section.

To reiterate: Workbooks(2) can be any Excel file that happened to be opened second after starting Excel. It may/may not be the desired file.

 

[wittonlin]

I am talking about Workbooks(2) (that is, an Excel file), not about Worksheets(2) (a sheet inside the file).

The line I was referring to is immediately below the Dim section.

To reiterate: Workbooks(2) can be any Excel file that happened to be opened second after starting Excel. It may/may not be the desired file.

Once again, spot on Tetra! I have no idea what condition, the dev that did this for us, was taking into consideration, but so far so good!

It just took using "Set wb = ActiveWorkbook" in place of the initial workbook references!

 

[wittonlin]

I hope Tetra sees this. What a fantastically useful macro! (he knows Thx agn Tetra!

Anyway, I'm trying to resolve an issue with the pasting portion that's always befuddled me.

Here's the entire macro that "in affect" CUTS non adjacent rows in a worksheet to the clipboard. Just not in the traditional form.

Option Explicit
Dim ColWidths()

Sub SelectionToClipboard()
    Dim i As Long, ii As Long, r As Range
    Dim AWB As Workbook, NWB As Workbook
    Set AWB = ActiveWorkbook
    Set NWB = Workbooks.Add
     
    With Application
        .ScreenUpdating = 0
        .EnableEvents = 0
        .Calculation = -4135
    End With
    With AWB.ActiveSheet.Cells(1).CurrentRegion
        AWB.Activate
        For i = 1 To .Columns.count
            ReDim Preserve ColWidths(1 To i)
            ColWidths(i) = .Columns(i).ColumnWidth
        Next
        i = 0
        ReDim x(1 To Selection.count / .Parent.Columns.count, 1 To .Columns.count)
        For Each r In Selection
            If r.Column = 1 Then
                For ii = 1 To .Columns.count
                    x(i + 1, ii) = r.Offset(, ii - 1)
                Next
                i = i + 1
            End If
        Next
        Selection.EntireRow.Delete
        Application.Goto AWB.ActiveSheet.[A1]
    End With
    With NWB.Sheets(1).[A1]
        .Parent.Activate
        AWB.ActiveSheet.Cells(1).CurrentRegion.Rows(1).Copy
        .PasteSpecial 8
        .Resize(UBound(x, 1), UBound(x, 2)) = x
        .Parent.Cells(1).CurrentRegion.VerticalAlignment = -4108
        Application.DisplayAlerts = 0
        .Parent.Cells(1).CurrentRegion.Copy
    End With
    NWB.Close 0
    With Application
        .CutCopyMode = False
        .EnableEvents = 1
        .Calculation = -4105
    End With
     
End Sub

Here's the paste function, I believe to also reset the Windows clipboard.

Sub FormatClipboardPaste()
    Dim i As Long
     
    With Application
        .ScreenUpdating = 0
        .EnableEvents = 0
        .Calculation = -4135
    End With
    With ActiveSheet
        For i = 1 To UBound(ColWidths)
            .Columns(i).ColumnWidth = ColWidths(i)
        Next
        With Selection
            .Rows.AutoFit
            .VerticalAlignment = xlCenter
        End With
        With Application
            .Goto .[A1]
            .ScreenUpdating = 0
            .EnableEvents = 0
            .Calculation = -4135
        End With
    End With
    
    Call settextsize
     
End Sub

It works perfectly under every case, accept one, when there's rows in the way and you need to INSERT the rows from the clipboard.

So just to keep it as easy as I could, I highlight the number of rows needed using the base 'insert-shift' macro here...

Sub InsertClipboardUnderSelectedRow()
    Selection.Insert Shift:=xlDown
End Sub

Then I'm able to use the base 'ActiveSheet.Paste' to paste the results into the proper numbers of rows already on the clipboard and call the macro above 'FormatClipboardPaste' within this little Macro.

Sub ActiveSheetPasteClipboardFormat()
    Call ActiveSheetPaste
    Call FormatClipboardPaste
End Sub

I just can't figure out how to go directly from 'SelectionToClipboard' then able to INSERT these rows into (from) any selected row.

It's already a BLESSING. This would just be icying on the cake!

Peace!

 

[wittonlin]

Oops my mistake. Tetra didn't code this originally. Just for the record.

 

[wittonlin]

I've still not found a solution to INSERTING the selection I have on the clipboard.

I tried changing the code here and it was close, but very odd!

I replaced this section:

        With Selection
            .Rows.AutoFit
            .VerticalAlignment = xlCenter
        End With

With this...

        With Selection
            .Rows.Insert shift:=xlShiftDown
        End With

And it inserts the exact # of rows, but with blank rows, THEN pastes the rows on the clipboard and STILL overwrites the rows below where I selected to insert rows.

Sub FormatClipboardPaste()
    Dim i As Long
     
    With Application
        .ScreenUpdating = 0
        .EnableEvents = 0
        .Calculation = -4135
    End With
    With ActiveSheet
        For i = 1 To UBound(ColWidths)
            .Columns(i).ColumnWidth = ColWidths(i)
        Next
        With Selection
            .Rows.AutoFit
            .VerticalAlignment = xlCenter
        End With
        With Application
            .Goto .[A1]
            .ScreenUpdating = 0
            .EnableEvents = 0
            .Calculation = -4135
        End With
    End With
    
    Call settextsize
     
End Sub

This all steams from the fact that our 'SelectionToClipboard' macro in affect 'CUTS' nonadjacent rows to the clipboard perfectly, just not to windows traditional clipboard. This is making it very difficult to INSERT those rows back. Just pasting into a new wb or sheet or area with no other data is a piece of cake.