VBA coding

[Aberdham]

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 !

 

[Aberdham]

Re: Need help with VBA coding

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 !

I would like to transfer the respective columns from the 2 output sheets to sheet 3

 

[Aberdham]

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

 

[rlv01]

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"

 

[mumps]

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:

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

 

[mumps]

Re: Need help with VBA coding

It can be shortened to this:

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

 

[Aberdham]

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"

Thanks for posting. I have already had that enabled.

 

[Aberdham]

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:

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

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.

 

[rlv01]

Re: Need help with VBA coding

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 !

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.

 

[Aberdham]

Re: Need help with VBA coding

It can be shortened to this:

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

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