Hi there, I need help please?
I have a Workbook, however the VBA I use to copy columns from sheet "Temp" to "Analyse" does not order them into the correct order on paste. They appear in the order of the "Temp" sheet.
The "Temp" sheet has many more columns that are pasted from a Windows App which is a problem too as I cannot seem to specify the whole "Temp" and "Analyse" sheets type as Text either and I have no control over the order of the columns that they are being copied from. "Temp" is also a hidden sheet. Rows can be anything from a couple to 2000.
There are two Windows sources that are used, hence the rename column headers part added.
I also have a sheet called "Search" with buttons on to make things easier. There is more to the spreadsheet that I have not included, but need assistance optimizing the code. I am using VLOOKUP to populate columns in the "Ananlyse" sheet which I would like to do with VBA instead, but that's for another day.
I did considder INDEX and MATCH, but I need this to be fast due to a Query that runs and updates a table used for the VLOOKUP on opening the Workbook, that is already slow. I tried posting the workbook, but I'm developing on it and there is much that has changed since my inicial request. 1298478-a-combination-spreadsheet-as-database-userform-onsheet-userform-and-vba-to-do-stuff.
So...
I use this at the top of this Module "Utilities" and other code follows for compatibility and similar in other modules for other functions.
Option Explicit
#If VBA7 Then
#If Win64 Then
Private Declare PtrSafe Function GetWindowLongPtr Lib "user32" Alias "GetWindowLongPtrA" _
(ByVal hWnd As Long, _
ByVal nIndex As Long _
) As LongPtr
#Else
Private Declare PtrSafe Function GetWindowLongPtr Lib "user32" Alias "GetWindowLongA" _
(ByVal hWnd As Long, _
ByVal nIndex As Long _
) As LongPtr
#End If
#If Win64 Then
Private Declare PtrSafe Function SetWindowLongPtr Lib "user32" Alias "SetWindowLongPtrA" _
(ByVal hWnd As LongPtr, _
ByVal nIndex As Long, _
ByVal dwNewLong As LongPtr _
) As LongPtr
#Else
Private Declare PtrSafe Function SetWindowLongPtr Lib "user32" Alias "SetWindowLongA" _
(ByVal hWnd As LongPtr, _
ByVal nIndex As Long, _
ByVal dwNewLong As LongPtr _
) As LongPtr
#End If
Private Declare PtrSafe Function SetWindowPos Lib "user32" _
(ByVal hWnd As LongPtr, _
ByVal hWndInsertAfter As LongPtr, _
ByVal X As Long, ByVal Y As Long, _
ByVal cx As Long, ByVal cy As Long, _
ByVal wFlags As Long _
) As LongPtr
Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" _
(ByVal lpClassName As String, _
ByVal lpWindowName As String _
) As LongPtr
Private Declare PtrSafe Function GetActiveWindow Lib "user32.dll" () As Long
Private Declare PtrSafe Function SendMessage Lib "user32" Alias "SendMessageA" _
(ByVal hWnd As LongPtr, _
ByVal wMsg As Long, _
ByVal wParam As Long, _
lParam As Any _
) As LongPtr
Private Declare PtrSafe Function DrawMenuBar Lib "user32" _
(ByVal hWnd As LongPtr) As LongPtr
#Else
Private Declare Function GetWindowLongPtr Lib "user32" Alias "GetWindowLongA" _
(ByVal hWnd As Long, _
ByVal nIndex As Long _
) As Long
Private Declare Function SetWindowLongPtr Lib "user32" Alias "SetWindowLongA" _
(ByVal hWnd As Long, _
ByVal nIndex As Long, _
ByVal dwNewLong As Long _
) As Long
Private Declare Function SetWindowPos Lib "user32" _
(ByVal hWnd As Long, _
ByVal hWndInsertAfter As Long, _
ByVal X As Long, ByVal Y As Long, _
ByVal cx As Long, ByVal cy As Long, _
ByVal wFlags As Long _
) As Long
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
(ByVal lpClassName As String, _
ByVal lpWindowName As String _
) As Long
Private Declare Function GetActiveWindow Lib "user32.dll" () As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" _
(ByVal hWnd As Long, _
ByVal wMsg As Long, _
ByVal wParam As Long, _
lParam As Any _
) As Long
Private Declare Function DrawMenuBar Lib "user32" _
(ByVal hWnd As Long) As Long
#End If
'Constants
Private Const SWP_NOMOVE = &H2
Private Const SWP_NOSIZE = &H1
Private Const GWL_EXSTYLE = (-20)
Private Const HWND_TOP = 0
Private Const SWP_NOACTIVATE = &H10
Private Const SWP_HIDEWINDOW = &H80
Private Const SWP_SHOWWINDOW = &H40
Private Const WS_EX_APPWINDOW = &H40000
Private Const GWL_STYLE = (-16)
Private Const WS_MINIMIZEBOX = &H20000
Private Const SWP_FRAMECHANGED = &H20
Private Const WM_SETICON = &H80
Private Const ICON_SMALL = 0&
Private Const ICON_BIG = 1&
The Paste code from Windows clipboard is as follows, it has about 50 columns.
Sub PasteFromClipboard() ' Windows only
Application.ScreenUpdating = False
ThisWorkbook.Sheets("Temp").Visible = True
On Error GoTo ErrorHandler
Sheets("Temp").Cells.ClearContents
Sheets("Temp").Range("A1").PasteSpecial Paste:=xlPasteAll
Application.CutCopyMode = False
Sheets("Temp").Activate
RenameColumnNames
ThisWorkbook.Sheets("Temp").Visible = False
Application.ScreenUpdating = True
Sheets("Search").Activate
MsgBox "Paste sucessful, Please click Analyse."
Exit Sub
ErrorHandler: ' This seems to work as it should
MsgBox "Nothing to paste!"
ThisWorkbook.Sheets("Temp").Visible = False
Sheets("Search").Activate
Application.ScreenUpdating = True
Exit Sub
End Sub
The code I am using to copy from one sheet to the other I found on another thread and adapted, is:
Sub CopyColumns() 'Excel VBA to move Columns based on criteria
Application.ScreenUpdating = False
ThisWorkbook.Sheets("Temp").Visible = True
Dim r As Range
Dim ar As Variant
Dim i As Integer
Dim fn As Range
Dim str As String
'Set the Array Values
ar = Array("CRN", "Customer Name", "Circuit/Equip ID", "Extension", "SLA", "Service Type", "Status")
For i = 0 To UBound(ar) 'Loop through the Array
Sheets("Temp").Select
Set fn = [A1:AW1].Find(ar(i), LookAt:=xlWhole)
On Error GoTo ErrorHandler2
str = str & fn.Address & ","
Next i 'Take the trailing comma from the string
str = Left(str, Len(str) - 1)
Set r = Range(str).EntireColumn
r.Copy Sheet6.[A1] 'Copy and Paste to new sheet in cell A1. This is the Analyse sheet. I would be happier with a named sheet here.
Sheets("Analyse").Activate
Columns("A:J").Select
Selection.EntireColumn.AutoFit
ActiveSheet.Cells(1, 1).Select
Sheets("Temp").Activate
Sheets("Temp").Cells.ClearContents ' Clear the contents of the "Temp" sheet.
ThisWorkbook.Sheets("Temp").Visible = False
Application.CutCopyMode = False 'Clear Excel Clipboard
Application.ScreenUpdating = True
Exit Sub
ErrorHandler2:
MsgBox "Nothing to Analyse!"
Sheets("Analyse").Activate
Columns("A:G").Select 'H:J are
Selection.Columns.ClearContents
ThisWorkbook.Sheets("Temp").Visible = False
Sheets("Search").Activate
Application.ScreenUpdating = True
Exit Sub
End Sub
I have included the Rename part that is called during CopyColumns. It's quite rough, and I was busy trying to figure a better method.
"Temp" is a hidden sheet.
Sub RenameColumnNames()
Application.ScreenUpdating = False
ThisWorkbook.Sheets("Temp").Visible = True
'Dim TH As Range
'Dim ws As Worksheet
'Dim rngHeaders As Range
'Set TH = Sheets("Temp").Rows("1:1")
On Error Resume Next
With Selection.Find(What:="Cct No/Eq ID", After:=ActiveCell, LookIn:= _
xlFormulas, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:= _
xlNext).Activate
ActiveCell.Replace What:="Cct No/Eq ID", Replacement:="Circuit/Equip Id", _
LookAt:=xlWhole, SearchOrder:=xlByRows
End With
With Selection.Find(What:="Customer", After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext).Activate
ActiveCell.Replace What:="Customer", Replacement:="Customer Name", LookAt _
:=xlWhole, SearchOrder:=xlByRows
Range("A1").Select
End With
'Reason for only renaming one two columns is that they are only wrong on one of the source pastes.
ThisWorkbook.Sheets("Temp").Visible = False
Application.ScreenUpdating = True
End Sub
For interest, my VLOOKUP is prepopulated in "Analyse" columns H:J from rows 1 to 2000, but shows a message if cells in column D has no value or is not an exact match. I need to figure a way to populate the VLOOKUP using xlUP or something along those lines.
Bookmarks