VBA coding

Excel Facts

Highlight Duplicates
Home, Conditional Formatting, Highlight Cells, Duplicate records, OK to add pink formatting to any duplicates in selected range.
Sort by date Sort by votes
Re: Need help with VBA coding

Aberdham said:
Hi there,

I tried to combine sheets with different columns to a new sheet. and ran the code. but it says user-type not defined.

following link to the workbook: https://1drv.ms/x/s!Aqt4VfikFsyKdP__4BbJF1LMxlM

could anyone help me to run a debug?

Thank you in advance !
Click to expand...

I would like to transfer the respective columns from the 2 output sheets to sheet 3
 
Upvote 0
Re: Need help with VBA coding

Below is the code:

Public Sub CombineSheetsWithDifferentHeaders()

Dim wksDst As Worksheet, wksSrc As Worksheet
Dim lngIdx As Long, lngLastSrcColNum As Long, _
lngFinalHeadersCounter As Long, lngFinalHeadersSize As Long, _
lngLastSrcRowNum As Long, lngLastDstRowNum As Long
Dim strColHeader As String
Dim varColHeader As Variant
Dim rngDst As Range, rngSrc As Range
Dim dicFinalHeaders As Scripting.Dictionary
Set dicFinalHeaders = New Scripting.Dictionary

'Set references up-front
dicFinalHeaders.CompareMode = vbTextCompare
lngFinalHeadersCounter = 1
lngFinalHeadersSize = dicFinalHeaders.Count
Set wksDst = ThisWorkbook.Worksheets.Add

If wksSrc.Name <> wksDst.Name Then

With wksSrc

lngLastSrcColNum = LastOccupiedColNum(wksSrc)
For lngIdx = 1 To lngLastSrcColNum

strColHeader = Trim(CStr(.Cells(1, lngIdx)))
If Not dicFinalHeaders.Exists(strColHeader) Then
dicFinalHeaders.Add Key:=strColHeader, _
Item:=lngFinalHeadersCounter
lngFinalHeadersCounter = lngFinalHeadersCounter + 1
End If

Next lngIdx

End With

End If

Next wksSrc

For Each varColHeader In dicFinalHeaders.Keys
wksDst.Cells(1, dicFinalHeaders(varColHeader)) = CStr(varColHeader)
Next varColHeader


'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''



If wksSrc.Name <> wksDst.Name Then

With wksSrc

lngLastSrcRowNum = LastOccupiedRowNum(wksSrc)
lngLastSrcColNum = LastOccupiedColNum(wksSrc)

lngLastDstRowNum = LastOccupiedRowNum(wksDst)

For lngIdx = 1 To lngLastSrcColNum
strColHeader = Trim(CStr(.Cells(1, lngIdx)))

Set rngDst = wksDst.Cells(lngLastDstRowNum + 1, _
dicFinalHeaders(strColHeader))

Set rngSrc = .Range(.Cells(2, lngIdx), _
.Cells(lngLastSrcRowNum, lngIdx))
rngSrc.Copy Destination:=rngDst

Next lngIdx

End With

End If

Next wksSrc


End Sub

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Public Function LastOccupiedRowNum(Sheet As Worksheet) As Long
Dim lng As Long
If Application.WorksheetFunction.CountA(Sheet.Cells) <> 0 Then
With Sheet
lng = .Cells.Find(What:="*", _
After:=.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
End With
Else
lng = 1
End If
LastOccupiedRowNum = lng
End Function

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Public Function LastOccupiedColNum(Sheet As Worksheet) As Long
Dim lng As Long
If Application.WorksheetFunction.CountA(Sheet.Cells) <> 0 Then
With Sheet
lng = .Cells.Find(What:="*", _
After:=.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Column
End With
Else
lng = 1
End If
LastOccupiedColNum = lng
End Function
 
Upvote 0
Re: Need help with VBA coding

I suspect you are missing a needed Object Library reference. In the VBA editor, open "References" (Tools-References) and check the box for "Microsoft Scripting Runtime"
 
Upvote 0
Re: Need help with VBA coding

Your Sheet1 is missing a column for "Invoice Date". Insert a new column between "Net Amount" and "exchange" and then run this macro:
Code: 
Sub CopyCols()
    Application.ScreenUpdating = False
    Dim bottomA As Long
    Dim ws As Worksheet
    For Each ws In Sheets
        If ws.Name <> "Sheet1" Then
            If ws.Name = "Purchase  USD" Then
                bottomA = ws.Range("A" & Rows.Count).End(xlUp).Row
                Intersect(ws.Rows("2:" & bottomA), ws.Range("A:A,D:E,G:G,K:L,N:N,S:S")).Copy Sheets("Sheet1").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
            ElseIf ws.Name = "Purchase EUR" Then
                bottomA = ws.Range("A" & Rows.Count).End(xlUp).Row
                Intersect(ws.Rows("2:" & bottomA), ws.Range("A:A,D:F,J:K,M:M,S:S")).Copy Sheets("Sheet1").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
            End If
        End If
    Next ws
    Application.ScreenUpdating = True
End Sub
 
Last edited:
Upvote 0
Re: Need help with VBA coding

It can be shortened to this:
Code: 
Sub CopyCols()
    Application.ScreenUpdating = False
    Dim bottomA As Long
    Dim ws As Worksheet
    For Each ws In Sheets
        If ws.Name = "Purchase  USD" Then
            bottomA = ws.Range("A" & Rows.Count).End(xlUp).Row
            Intersect(ws.Rows("2:" & bottomA), ws.Range("A:A,D:E,G:G,K:L,N:N,S:S")).Copy Sheets("Sheet1").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
        ElseIf ws.Name = "Purchase EUR" Then
            bottomA = ws.Range("A" & Rows.Count).End(xlUp).Row
            Intersect(ws.Rows("2:" & bottomA), ws.Range("A:A,D:F,J:K,M:M,S:S")).Copy Sheets("Sheet1").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
        End If
    Next ws
    Application.ScreenUpdating = True
End Sub
 
Upvote 0
Re: Need help with VBA coding

rlv01 said:
I suspect you are missing a needed Object Library reference. In the VBA editor, open "References" (Tools-References) and check the box for "Microsoft Scripting Runtime"
Click to expand...

Thanks for posting. I have already had that enabled.
 
Upvote 0
Re: Need help with VBA coding

mumps said:
Your Sheet1 is missing a column for "Invoice Date". Insert a new column between "Net Amount" and "exchange" and then run this macro:
Code: 
Sub CopyCols()
    Application.ScreenUpdating = False
    Dim bottomA As Long
    Dim ws As Worksheet
    For Each ws In Sheets
        If ws.Name <> "Sheet1" Then
            If ws.Name = "Purchase  USD" Then
                bottomA = ws.Range("A" & Rows.Count).End(xlUp).Row
                Intersect(ws.Rows("2:" & bottomA), ws.Range("A:A,D:E,G:G,K:L,N:N,S:S")).Copy Sheets("Sheet1").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
            ElseIf ws.Name = "Purchase EUR" Then
                bottomA = ws.Range("A" & Rows.Count).End(xlUp).Row
                Intersect(ws.Rows("2:" & bottomA), ws.Range("A:A,D:F,J:K,M:M,S:S")).Copy Sheets("Sheet1").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
            End If
        End If
    Next ws
    Application.ScreenUpdating = True
End Sub
Click to expand...

Hi mumps, thanks a lot for your help ! it works great... :)

I am wondering if it is possible to modified the code to do a filter on column A (only material) and column F ( dated between 01.04-30.04.2018)

and if it is possible to drag it to a new workbook instead of a new sheet within the same workbook?

it would be great if you could help me further !

Thank you in advance.
 
Upvote 0
Re: Need help with VBA coding

Aberdham said:
I tried to combine sheets with different columns to a new sheet. and ran the code. but it says user-type not defined.

following link to the workbook: https://1drv.ms/x/s!Aqt4VfikFsyKdP__4BbJF1LMxlM

could anyone help me to run a debug?

Thank you in advance !
Click to expand...

What happened to that "user-type not defined" error you were asking for help with? I was able to run your code without encountering any error messages unless I started to un-check library references.
 
Upvote 0
Re: Need help with VBA coding

mumps said:
It can be shortened to this:
Code: 
Sub CopyCols()
    Application.ScreenUpdating = False
    Dim bottomA As Long
    Dim ws As Worksheet
    For Each ws In Sheets
        If ws.Name = "Purchase  USD" Then
            bottomA = ws.Range("A" & Rows.Count).End(xlUp).Row
            Intersect(ws.Rows("2:" & bottomA), ws.Range("A:A,D:E,G:G,K:L,N:N,S:S")).Copy Sheets("Sheet1").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
        ElseIf ws.Name = "Purchase EUR" Then
            bottomA = ws.Range("A" & Rows.Count).End(xlUp).Row
            Intersect(ws.Rows("2:" & bottomA), ws.Range("A:A,D:F,J:K,M:M,S:S")).Copy Sheets("Sheet1").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
        End If
    Next ws
    Application.ScreenUpdating = True
End Sub
Click to expand...


Hi rlv01,

please refer to #post 5 and #post 6
mumps has specified the issues.
I am wondering if the further criteria from #post 8 can be done.
that would be much appreciated !

cheers
M
 
Upvote 0
You must log in or register to reply here.

Similar threads

O
  • Question Question
Frustrating intermittent VBA error dialog telling me that "User-define Type Not Defined"
Replies
1
Views
241
Micron
M
A
  • Solved
VBA code to extract a table
Replies
5
Views
236
Anthony47
A
S
  • Solved
VBA - User defined type not defined error
Replies
4
Views
489
ssh99
S
itsMelly
  • Question Question
Help with checkbox macros
Replies
5
Views
306
MikeVol
MikeVol
N
  • Question Question
Assistant with VBA code from formula
Replies
8
Views
185
RoryA
RoryA

Forum statistics

Threads
1,223,903
Messages
6,175,289
Members
452,631
Latest member
a_potato

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