Changing formats while copying from an open workbook to another

zubinnajmi · Sep 27th 2019

Hi Friends,
Am glad I have this forum to pull me out of my difficulties.
Here I am having a workbook open from which certain column ranges have to pulled and copied in a new workbook, The below code does exactly as i want.
The problem comes when I have to upload the new workbook to a website as the formats don't match.

1) The range M1:M300 contains SALE figures. If the sale figure is ZERO then the cell has to be left BLANK in the destination range F1:F300 and otherwise the other cells which have a sale figure to be copied as it is.

The rest of the ranges contain DATA which have to be copied in the same format (General) as they are in their respective ranges in the workbook.

Please Guide.

Code

[INDENT]
 'Command Button For "Upload Report" Private Sub CommandButton11_Click() Dim samePath As String Dim wb As Workbook Dim Range1, Range2, Range3, Range4, Range5, Range6 As Range Dim DestRange1, DestRange2, DestRange3, DestRange4, DestRange5, DestRange6 As Range Dim my_Name As String Dim strDate  strDate = ActiveSheet.Name my_Name = InputBox("Enter Date MM-DD-YYYY", "Fravashi Beer and Wine Shop", "SCMSales") samePath = ActiveWorkbook.Path & "\" & my_Name & strDate  If my_Name = " " Then  Exit Sub ElseIf my_Name = "" Then Exit Sub End If  Set Range1 = ActiveSheet.Range("M1:M300") 'Quantity Loose bottles Sold Set Range2 = ActiveSheet.Range("T1:T300") 'Sale date Set Range3 = ActiveSheet.Range("Q1:Q300") 'Local item Code Set Range4 = ActiveSheet.Range("R1:R300") 'Brand name Set Range5 = ActiveSheet.Range("S1:S300") 'Size Set Range6 = ActiveSheet.Range("DA1:DA300") 'Quantity case Sold  With Workbooks.Add Set wb = ActiveWorkbook With wb.ActiveSheet Set DestRange1 = ActiveSheet.Range("F1:F300") Set DestRange2 = ActiveSheet.Range("A1:A300") Set DestRange3 = ActiveSheet.Range("B1:B300") Set DestRange4 = ActiveSheet.Range("C1:C300") Set DestRange5 = ActiveSheet.Range("D1:D300") Set DestRange6 = ActiveSheet.Range("E1:E300") End With End With  Range1.Copy DestRange1.PasteSpecial Paste:=xlPasteValues DestRange1.PasteSpecial Paste:=xlPasteColumnWidths DestRange3.PasteSpecial Paste:=xlPasteFormats Range2.Copy DestRange2.PasteSpecial Paste:=xlPasteValues DestRange2.PasteSpecial Paste:=xlPasteColumnWidths DestRange3.PasteSpecial Paste:=xlPasteFormats Range3.Copy DestRange3.PasteSpecial Paste:=xlPasteValues DestRange3.PasteSpecial Paste:=xlPasteColumnWidths DestRange3.PasteSpecial Paste:=xlPasteFormats Range4.Copy DestRange4.PasteSpecial Paste:=xlPasteValues DestRange4.PasteSpecial Paste:=xlPasteColumnWidths DestRange4.PasteSpecial Paste:=xlPasteFormats Range5.Copy DestRange5.PasteSpecial Paste:=xlPasteValues DestRange5.PasteSpecial Paste:=xlPasteColumnWidths DestRange5.PasteSpecial Paste:=xlPasteFormats Range6.Copy DestRange6.PasteSpecial Paste:=xlPasteValues DestRange6.PasteSpecial Paste:=xlPasteColumnWidths DestRange6.PasteSpecial Paste:=xlPasteFormats  Application.CutCopyMode = False ActiveSheet.Range("G1").Select  wb.SaveAs Filename:=samePath wb.Close Application.ScreenUpdating = True Range("B4").Select End Sub[/INDENT]

[IMG2=JSON]{"data-align":"none","data-size":"full","src":"https:\/\/www.excelforum.com\/clear.gif"}[/IMG2]Edit Post [IMG2=JSON]{"data-align":"none","data-size":"full","src":"https:\/\/www.excelforum.com\/clear.gif"}[/IMG2]Reply [IMG2=JSON]{"data-align":"none","data-size":"full","src":"https:\/\/www.excelforum.com\/clear.gif"}[/IMG2]Reply With Quote [IMG2=JSON]{"data-align":"none","data-size":"full","src":"https:\/\/www.excelforum.com\/images\/buttons\/multiquote_40b.png"}[/IMG2] Add Reputation Report Post

**Carim** · Sep 27th 2019

Hi,

It looks like your problem is just to hide zero values ...

Below is a link which necessary explanations :

https://support.office.com/en-…b8-4516-8085-a00e9e476b03

Hope this will help

zubinnajmi · Sep 27th 2019

Hi Carim,
No the object is not to hide zeroes, they are already hidden and the destination worksheet range shows blank, but when you click on a cell the formula bar shows zero, this should not happen because the destination worksheet has to be uploaded to website and the hidden zeroes create a "format not match" problem. so we should have blank cells instead of zeroes in the destination worksheet.
Please help
Regards
Zubin

**Carim** · Sep 27th 2019

Hi,

You could test the following

Code

Sub Test()
    Cells.Replace What:="0", Replacement:="", LookAt:=xlWhole
End Sub

Hope this will help

zubinnajmi · Sep 27th 2019

Hi,
No ......Nothing is happening.....should i post the worksheet

**Carim** · Sep 27th 2019

Hi again,

Attaching your test file ... would indeed make things a lot easier ... :wink:

zubinnajmi · Sep 27th 2019

Please refer to attached worksheet...
There is a command button "Upload report"

**Carim** · Sep 27th 2019

Thanks for the file ...

So you are performing a Copy Paste Values ... from AU1:AU3000 to F1:F3000

And the objective is to remove all Zero Values in the F column ...

Is my understanding correct ?

zubinnajmi · Sep 27th 2019

Yes correct.........the source worksheet range "AU" has the sale data or the no. of items sold for which certain items can have zero sale values.....These values are copied to destination worksheet. all i need is only that the destination worksheet colum "F" should not show the zero values in the corresponding sale values.
If you notice with this code the zero values are hidden in the destination folder but when you click on the cell the zero shows up in the formula bar.....this is what is creating problem
Once again i am thankful to you for devoting your time for me
Regards
zubin

**KjBox** · Sep 27th 2019

You could simply change your formula in column AU from

=AS2+AS3002

to

=IF(AS2+AS3002=0,"",AS2+AS3002)

zubinnajmi · Sep 27th 2019

Hi KJBox,
Thanks for your reply..... I have already tried all this, problem is... there are three more column ranges who's value depend on this column, If i change this to "IF" then there is an error "#Value" in the corresponding column and this has an cascading effect on other columns in the source worksheet.
so i better thought to change this in the destination worksheet.
I have uploaded the workbook for your reference.
Please find a solution
Regards
Zubin

**KjBox** · Sep 27th 2019

In that case, this is the code I would use

Code

Private Sub CommandButton11_Click()
    Dim x, y, Cols, i As Long, ii As Long, wbk As Workbook
    Dim sFileName As String, sPath As String
    
    x = ActiveSheet.Cells(1).CurrentRegion.Resize(3000)
    ReDim y(1 To UBound(x, 1), 1 To 6)
    Cols = Array(36, 37, 38, 39, 46, 47)
    sPath = ActiveWorkbook.Path & Application.PathSeparator
    sFileName = Format(Date, "mm-dd-yyyy") & ActiveSheet.Name
    
    For i = 1 To UBound(x, 1)
        For ii = 0 To 5
            y(i, ii + 1) = x(i, Cols(ii))
        Next
        If y(i, 6) = 0 Then y(i, 6) = vbNullString
    Next
    Application.ScreenUpdating = 0
    Set wbk = Workbooks.Add
    With wbk.Sheets(1).[a1].Resize(UBound(y, 1), 6)
        .Value = y
        .Rows(1).Interior.Color = 65535
        With .Columns(5).Resize(, 2)
            .HorizontalAlignment = -4108
            .VerticalAlignment = -4108
            .NumberFormat = "0"
        End With
        .Columns(1).ColumnWidth = 11.09: .Columns(2).ColumnWidth = 15.09
        .Columns(3).ColumnWidth = 49.55: .Columns(4).ColumnWidth = 12.91
        .Columns(5).ColumnWidth = 20.09: .Columns(6).ColumnWidth = 24.91
        .Borders.Weight = 2
        With .Rows(1)
            .Borders.Weight = 3
            .Font.Bold = 1
            .HorizontalAlignment = -4108
            .VerticalAlignment = -4108
        End With
        Application.Goto .Parent.[g1]
        .Parent.Parent.SaveAs sPath & sFileName
        .Parent.Parent.Close
    End With
    Application.Goto [b4]
    
End Sub

Display More

zubinnajmi · Sep 28th 2019

Hi, Good Morning KJBox.....
Don't know how to describe you.....Genius nothing less.....not only you solved the problem but your coding works lightening fast
are there different vba coding languages like other programming languages ???.....every time i get to learn something new....Thanks anyways
Ok one small request please ....like in the original code can you get back the initial dialog box asking for the name of the destination (New) workbook..actually it is very important, as the system date is pulled up automatically and sometimes the uploading is done on a different date.......
Rest all is fine and thanks a lot....

**KjBox** · Sep 28th 2019

Here you go, note I changed the new file name to have an underscore between the 2 dates, makes it much more readable.

Code

Private Sub CommandButton11_Click()
    Dim x, y, Cols, i As Long, ii As Long, wbk As Workbook
    Dim sFileName As String, sPath As String, sDt As String
    
    x = ActiveSheet.Cells(1).CurrentRegion.Resize(3000)
    ReDim y(1 To UBound(x, 1), 1 To 6)
    Cols = Array(36, 37, 38, 39, 46, 47)
    sPath = ActiveWorkbook.Path & Application.PathSeparator
    sDt = InputBox("Enter Date MM-DD-YYYY", "Fravashi Beer and Wine Shop", "SCMSales")
    sFileName = sDt & "_" & ActiveSheet.Name
    
    For i = 1 To UBound(x, 1)
        For ii = 0 To 5
            y(i, ii + 1) = x(i, Cols(ii))
        Next
        If y(i, 6) = 0 Then y(i, 6) = vbNullString
    Next
    Application.ScreenUpdating = 0
    Set wbk = Workbooks.Add
    With wbk.Sheets(1).[a1].Resize(UBound(y, 1), 6)
        .Value = y
        With .Columns(5).Resize(, 2)
            .HorizontalAlignment = -4108
            .VerticalAlignment = -4108
            .NumberFormat = "0"
        End With
        .Columns(1).ColumnWidth = 11.09: .Columns(2).ColumnWidth = 15.09
        .Columns(3).ColumnWidth = 49.55: .Columns(4).ColumnWidth = 12.91
        .Columns(5).ColumnWidth = 20.09: .Columns(6).ColumnWidth = 24.91
        .Borders.Weight = 2
        With .Rows(1)
            .Interior.Color = 65535
            .Borders.Weight = 3
            .Font.Bold = 1
            .HorizontalAlignment = -4108
            .VerticalAlignment = -4108
        End With
        Application.Goto .Parent.[g1]
        .Parent.Parent.SaveAs sPath & sFileName
        .Parent.Parent.Close
    End With
    Application.Goto [b4]
    
End Sub

Display More

zubinnajmi · Sep 28th 2019

KJBox......Thanks a million
You Have done a lot.....Now i need to learn a lot.
Thanks again

zubinnajmi · Sep 29th 2019

Thanks

**KjBox** · Oct 17th 2019

In reply to your visitor message, try this

Code

Option Explicit


'Command Button For "Upload Report"
Private Sub CommandButton11_Click()
    Dim x, y(), Cols, i As Long, ii As Long, lCnt As Long, wbk As Workbook
    Dim Hdrs(1 To 6), e, sFileName As String, sPath As String, sDt As String
    
    x = ActiveSheet.Cells(1).CurrentRegion.Resize(3000)
    Cols = Array(36, 37, 38, 39, 46, 47)
    sPath = ActiveWorkbook.Path & Application.PathSeparator
    sDt = InputBox("Enter Date MM-DD-YYYY", "Fravashi Beer and Wine Shop", "SCMSales")
    sFileName = sDt & "_" & ActiveSheet.Name
    
    For Each e In Cols
        i = i + 1: Hdrs(i) = x(1, e)
    Next
    For i = 2 To UBound(x, 1)
        If x(i, 47) > 0 Then
            lCnt = lCnt + 1: ReDim Preserve y(1 To 6, 1 To lCnt)
            For ii = 0 To 5
                y(ii + 1, lCnt) = x(i, Cols(ii))
            Next
            If y(6, lCnt) = 0 Then y(6, lCnt) = vbNullString
        End If
    Next
    If icnt > 0 Then
        Application.ScreenUpdating = 0
        Set wbk = Workbooks.Add
        wbk.Sheets(1).[a1].Resize(, 6) = Hdrs
        With wbk.Sheets(1).[a2].Resize(lCnt, 6)
            .Value = Application.Transpose(y)
            With .Columns(5).Resize(, 2)
                .HorizontalAlignment = -4108
                .VerticalAlignment = -4108
                .NumberFormat = "0"
            End With
            .Columns(1).ColumnWidth = 11.09: .Columns(2).ColumnWidth = 15.09
            .Columns(3).ColumnWidth = 49.55: .Columns(4).ColumnWidth = 12.91
            .Columns(5).ColumnWidth = 20.09: .Columns(6).ColumnWidth = 24.91
            .Borders.Weight = 2
            With .Rows(1)
                .Interior.Color = 65535
                .Borders.Weight = 3
                .Font.Bold = 1
                .HorizontalAlignment = -4108
                .VerticalAlignment = -4108
            End With
            Application.Goto .Parent.[g1]
            .Parent.Parent.SaveAs sPath & sFileName
            .Parent.Parent.Close
        End With
    Else
        MsgBox "No Loose Bottle Sales"
    End If
    Application.Goto [b4]
    
End Sub

Display More

zubinnajmi · Oct 17th 2019

Hi, Good Morning..
Great.....Works beautiful....
Once again and again Thanks a Ton
Regards
Zubin

**KjBox** · Oct 17th 2019

You're welcome

Changing formats while copying from an open workbook to another

Participate now!

Share